Attached is an initial reference implementation of:
* curly-write-simple and neoteric-write-simple
* [curly,neoteric]-write-[shared,cyclic]
It then does:
 (define neoteric-write neoteric-write-cyclic)
 (define curly-write curly-write-cyclic)

Comments/improvements welcome!  The "simple" implementations is separable from the shared/cyclic implementation, so that those who don't want shared and cyclic versions can omit them.

I used the Chibi Scheme implementation as a starting point.  That builds on srfi-38, but it uses hash tables (more efficient) and can deal with both cyclic and shared structure versions.  The Chibi code for this is released to the public domain, so no license issue.

Below is the starting test set and its output, to show that it's plausible.  The test set is used by all; I can't (obviously) include cycles in the calls to the -simple variants.

--- David A. Wheeler

============= Basic tests =============================

(define basic-tests
  '(
    (+ 4 5)
    (quote x)
    (a b c d e f g h i j k l m n o p q r s t u v w x y z)
    (a b c d e f g h i j k l m n o p q r s t u v w x y z . 2)
    (a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
    (a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
    (+ a b)
    (+ a b c)
    (+ a b c . improper)
    (+ 1 2 3 4 5)
    (+ 1 2 3 4 5 6)
    (+ 1 2 3 4 5 6 7)
    (sin (- theta))
    (fact (- n 1))
    (calculate (pi))
    (between current min max)
    (my-write . rest)
    (sin x)
    (- x)
    (-)
    (function +)
    (map + '(2 4 6))
    (current-time)
    (1 2 3)
    (4 5 . 6)
    5
    boring-symbol
    (+ (sqrt x) (sqrt y))
    `(1 2 ,@(+ a b))
    (syntax (a b c))
    #(v1 v2 (+ 2 3) (sin x))
    (define (is-infix-operator? x)
      (cond ((not (symbol? x)) #f)
            ((memq x special-infix-operators) #t)
            (#t
             (contains-only-punctuation?
               (string->list (symbol->string x))))))
    fin))

============= Output (test results) =============================

curly-write-simple
{4 + 5}
'x
(a b c d e f g h i j k l m n o p q r s t u v w x y z)
(a b c d e f g h i j k l m n o p q r s t u v w x y z . 2)
(a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
(a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
{a + b}
{a + b + c}
(+ a b c . improper)
{1 + 2 + 3 + 4 + 5}
{1 + 2 + 3 + 4 + 5 + 6}
(+ 1 2 3 4 5 6 7)
(sin (- theta))
(fact {n - 1})
(calculate (pi))
(between current min max)
(my-write . rest)
(sin x)
(- x)
(-)
(function +)
(map + '(2 4 6))
(current-time)
(1 2 3)
(4 5 . 6)
5
boring-symbol
{sqrt(x) + sqrt(y)}
`(1 2 ,@{a + b})
#'(a b c)
#( v1 v2 {2 + 3} (sin x) )
(define (is-infix-operator? x) (cond ((not (symbol? x)) #f) ((memq x special-infix-operators) #t) (#t (contains-only-punctuation? (string->list (symbol->string x))))))
fin

neoteric-write-simple
{4 + 5}
'x
(a b c d e f g h i j k l m n o p q r s t u v w x y z)
(a b c d e f g h i j k l m n o p q r s t u v w x y z . 2)
a(2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
(a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
{a + b}
{a + b + c}
+(a b c . improper)
{1 + 2 + 3 + 4 + 5}
{1 + 2 + 3 + 4 + 5 + 6}
+(1 2 3 4 5 6 7)
sin{- theta}
fact{n - 1}
calculate(pi())
between(current min max)
my-write(. rest)
sin(x)
-(x)
-()
function(+)
map(+ '(2 4 6))
current-time()
(1 2 3)
(4 5 . 6)
5
boring-symbol
{sqrt(x) + sqrt(y)}
`(1 2 ,@{a + b})
#'a(b c)
#( v1 v2 {2 + 3} sin(x) )
define(is-infix-operator?(x) cond((not(symbol?(x)) #f) (memq(x special-infix-operators) #t) (#t contains-only-punctuation?(string->list(symbol->string(x))))))
fin

curly-write-shared
{4 + 5}
'x
(a b c d e f g h i j k l m n o p q r s t u v w x y z)
(a b c d e f g h i j k l m n o p q r s t u v w x y z . 2)
(a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
(a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
{a + b}
{a + b + c}
(+ a b c . improper)
{1 + 2 + 3 + 4 + 5}
{1 + 2 + 3 + 4 + 5 + 6}
(+ 1 2 3 4 5 6 7)
(sin (- theta))
(fact {n - 1})
(calculate (pi))
(between current min max)
(my-write . rest)
(sin x)
(- x)
(-)
(function +)
(map + '(2 4 6))
(current-time)
(1 2 3)
(4 5 . 6)
5
boring-symbol
{sqrt(x) + sqrt(y)}
`(1 2 ,@{a + b})
#'(a b c)
#(v1 v2 {2 + 3} (sin x))
(define (is-infix-operator? x) (cond ((not (symbol? x)) #f) ((memq x special-infix-operators) #t) (#t (contains-only-punctuation? (string->list (symbol->string x))))))
fin
(a b)
(begin #0=(a b) #0# end)
#0=(first . #0#)
(dosomething #0=(c1 c2) (b1 b2) #0#)
#0=(quote . #0#)

curly-write-cyclic
{4 + 5}
'x
(a b c d e f g h i j k l m n o p q r s t u v w x y z)
(a b c d e f g h i j k l m n o p q r s t u v w x y z . 2)
(a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
(a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
{a + b}
{a + b + c}
(+ a b c . improper)
{1 + 2 + 3 + 4 + 5}
{1 + 2 + 3 + 4 + 5 + 6}
(+ 1 2 3 4 5 6 7)
(sin (- theta))
(fact {n - 1})
(calculate (pi))
(between current min max)
(my-write . rest)
(sin x)
(- x)
(-)
(function +)
(map + '(2 4 6))
(current-time)
(1 2 3)
(4 5 . 6)
5
boring-symbol
{sqrt(x) + sqrt(y)}
`(1 2 ,@{a + b})
#'(a b c)
#(v1 v2 {2 + 3} (sin x))
(define (is-infix-operator? x) (cond ((not (symbol? x)) #f) ((memq x special-infix-operators) #t) (#t (contains-only-punctuation? (string->list (symbol->string x))))))
fin
(a b)
(begin (a b) (a b) end)
#0=(first . #0#)
(dosomething (c1 c2) (b1 b2) (c1 c2))
#0=(quote . #0#)

neoteric-write-shared
{4 + 5}
'x
(a b c d e f g h i j k l m n o p q r s t u v w x y z)
(a b c d e f g h i j k l m n o p q r s t u v w x y z . 2)
a(2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
(a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
{a + b}
{a + b + c}
+(a b c . improper)
{1 + 2 + 3 + 4 + 5}
{1 + 2 + 3 + 4 + 5 + 6}
+(1 2 3 4 5 6 7)
sin{- theta}
fact{n - 1}
calculate(pi())
between(current min max)
my-write(. rest)
sin(x)
-(x)
-()
function(+)
map(+ '(2 4 6))
current-time()
(1 2 3)
(4 5 . 6)
5
boring-symbol
{sqrt(x) + sqrt(y)}
`(1 2 ,@{a + b})
#'a(b c)
#(v1 v2 {2 + 3} sin(x))
define(is-infix-operator?(x) cond((not(symbol?(x)) #f) (memq(x special-infix-operators) #t) (#t contains-only-punctuation?(string->list(symbol->string(x))))))
fin
a(b)
begin(#0=a(b) #0# end)
#0=(first . #0#)
dosomething(#0=c1(c2) b1(b2) #0#)
#0=(quote . #0#)

neoteric-write-cyclic
{4 + 5}
'x
(a b c d e f g h i j k l m n o p q r s t u v w x y z)
(a b c d e f g h i j k l m n o p q r s t u v w x y z . 2)
a(2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
(a 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
{a + b}
{a + b + c}
+(a b c . improper)
{1 + 2 + 3 + 4 + 5}
{1 + 2 + 3 + 4 + 5 + 6}
+(1 2 3 4 5 6 7)
sin{- theta}
fact{n - 1}
calculate(pi())
between(current min max)
my-write(. rest)
sin(x)
-(x)
-()
function(+)
map(+ '(2 4 6))
current-time()
(1 2 3)
(4 5 . 6)
5
boring-symbol
{sqrt(x) + sqrt(y)}
`(1 2 ,@{a + b})
#'a(b c)
#(v1 v2 {2 + 3} sin(x))
define(is-infix-operator?(x) cond((not(symbol?(x)) #f) (memq(x special-infix-operators) #t) (#t contains-only-punctuation?(string->list(symbol->string(x))))))
fin
a(b)
begin(a(b) a(b) end)
#0=(first . #0#)
dosomething(c1(c2) b1(b2) c1(c2))
#0=(quote . #0#)