diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index a339a89..79e67a3 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -14,7 +14,8 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
   ikarus.lists.ss ikarus.load.ss ikarus.main.ss \
   ikarus.multiple-values.ss ikarus.numerics.ss \
   ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss \
-  ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss \
+  ikarus.pretty-print.ss ikarus.pretty-formats.ss \
+  ikarus.promises.ss ikarus.reader.ss \
   ikarus.records.procedural.ss ikarus.conditions.ss \
   ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
   ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \
diff --git a/scheme/Makefile.in b/scheme/Makefile.in
index 4018281..a5a4f3a 100644
--- a/scheme/Makefile.in
+++ b/scheme/Makefile.in
@@ -169,7 +169,8 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
   ikarus.lists.ss ikarus.load.ss ikarus.main.ss \
   ikarus.multiple-values.ss ikarus.numerics.ss \
   ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss \
-  ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss \
+  ikarus.pretty-print.ss ikarus.pretty-formats.ss \
+  ikarus.promises.ss ikarus.reader.ss \
   ikarus.records.procedural.ss ikarus.conditions.ss \
   ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
   ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \
diff --git a/scheme/ikarus.pretty-formats.ss b/scheme/ikarus.pretty-formats.ss
index 6cdf54e..d54ef6f 100644
--- a/scheme/ikarus.pretty-formats.ss
+++ b/scheme/ikarus.pretty-formats.ss
@@ -55,6 +55,7 @@
   (set-fmt! 'let-values '(_ (0 [e 0 e] ...) tab e tab e* ...))
   (set-fmt! 'cond '(_ tab [0 e ...] ...))
   (set-fmt! 'define '(_ name tab e ...))
+  (set-fmt! 'set! '(_ name tab e))
   (set-fmt! 'case-lambda 
      '(_ tab [0 e ...] ...))
   (set-fmt! 'struct-case 
diff --git a/scheme/ikarus.pretty-print.ss b/scheme/ikarus.pretty-print.ss
index 5031038..b49dffb 100644
--- a/scheme/ikarus.pretty-print.ss
+++ b/scheme/ikarus.pretty-print.ss
@@ -18,6 +18,7 @@
   (export pretty-print pretty-width)
   (import 
     (rnrs hashtables)
+    (only (ikarus writer) traverse traversal-helpers)
     (only (ikarus.pretty-formats) get-fmt)
     (except (ikarus) pretty-print pretty-width))
   (define (map1ltr f ls)
@@ -39,7 +40,7 @@
   (define-struct cbox (length boxes))
   (define-struct pbox (length ls last))
   (define-struct mbox (length str val))
-  (define-struct vbox (length ls))
+  (define-struct vbox (length prefix ls))
   (define-struct fbox (length box* sep*))
   (define (box-length x)
     (cond
@@ -50,7 +51,8 @@
       [(vbox? x)   (vbox-length x)]
       [(fbox? x)   (fbox-length x)]
       [else (die 'boxify "invalid box" x)]))
-  (define (boxify x)
+  (define (boxify x h)
+    (define shared-idx 0)
     (define (conc . a*)
       (let ([n 
              (let f ([a* a*] [len 0])
@@ -59,11 +61,11 @@
                  [else
                   (f (cdr a*) (fx+ len (box-length (car a*))))]))])
         (make-cbox n a*)))
-    (define (boxify-list ls alt-fmt*)
+    (define (boxify-list ls)
       (define (sum-box* ls)
         (cond
           [(null? (cdr ls)) 
-           (fx+ (box-length (car ls)) 2)]
+           (box-length (car ls))]
           [else 
            (fx+ (box-length (car ls)) 
                 (fxadd1 (sum-box* (cdr ls))))]))
@@ -82,16 +84,16 @@
           (cond
             [(not (pair? fmt)) #t]
             [(eq? (car fmt) 'read-macro)
-             (and (list? ls) (fx= (length ls) 2))]
+             (and (unshared-list? ls) (fx= (length ls) 2))]
             [else
              (let ([a (car fmt)] [fmt (cdr fmt)])
                (cond
                  [(or (eq? a 'tab) (fixnum? a))
                   (good-match? fmt ls)]
                  [(and (pair? fmt) (eq? (car fmt) '...))
-                  (and (list? ls)
+                  (and (unshared-list? ls)
                        (andmap (lambda (x) (good-match? a x)) ls))]
-                 [(pair? ls)
+                 [(and (pair? ls) (not (graphed? ls)))
                   (and (good-match? a (car ls))
                        (good-match? fmt (cdr ls)))]
                  [else #f]))]))
@@ -110,105 +112,111 @@
           [else       alt-fmt*]))
       (define (return sep* box*)
         (let ([n (sum-box* box*)])
-          (make-fbox n box* sep*)))
-      (let ([a (car ls)])
-        (cond
-          [(applicable-formats a alt-fmt*) =>
-           (lambda (fmt*)
-             (let ([fmt (select-alt fmt* ls)])
-               (module (fmt-dots? skip-fmt fmt-tab sub-fmt)
-                 (define (parse-fmt x)
-                   (define (parse-dots tab fmt x)
-                     (cond
-                       [(and (pair? x) (eq? (car x) '...))
-                        (values tab fmt #t (cdr x))]
-                       [else
-                        (values tab fmt #f x)]))
-                   (define (parse-tab tab x)
+          (conc "(" (make-fbox n box* sep*) ")")))
+      (define (boxify-list ls alt-fmt*)
+        (let ([a (car ls)])
+          (cond
+            [(applicable-formats a alt-fmt*) =>
+             (lambda (fmt*)
+               (let ([fmt (select-alt fmt* ls)])
+                 (module (fmt-dots? skip-fmt fmt-tab sub-fmt)
+                   (define (parse-fmt x)
+                     (define (parse-dots tab fmt x)
+                       (cond
+                         [(and (pair? x) (eq? (car x) '...))
+                          (values tab fmt #t (cdr x))]
+                         [else
+                          (values tab fmt #f x)]))
+                     (define (parse-tab tab x)
+                       (cond
+                         [(pair? x)
+                          (parse-dots tab (car x) (cdr x))]
+                         [else (values tab #f #f #f)]))
                      (cond
                        [(pair? x)
-                        (parse-dots tab (car x) (cdr x))]
-                       [else (values tab #f #f #f)]))
+                        (let ([a0 (car x)])
+                          (cond
+                            [(eq? a0 'tab) 
+                             (parse-tab (pretty-indent) (cdr x))]
+                            [(fixnum? a0) 
+                             (parse-tab a0 (cdr x))]
+                            [else (parse-tab #f x)]))]
+                       [else (values (pretty-indent) #f #f #f)]))
+                   (define (fmt-dots? x)
+                     (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
+                        dots))
+                   (define (fmt-tab x)
+                     (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
+                        tab))
+                   (define (sub-fmt x)
+                     (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
+                        subfmt))
+                   (define (skip-fmt x)
+                     (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
+                        fmt)))
+                 (define (boxify/fmt fmt x) 
                    (cond
-                     [(pair? x)
-                      (let ([a0 (car x)])
-                        (cond
-                          [(eq? a0 'tab) 
-                           (parse-tab (pretty-indent) (cdr x))]
-                          [(fixnum? a0) 
-                           (parse-tab a0 (cdr x))]
-                          [else (parse-tab #f x)]))]
-                     [else (values (pretty-indent) #f #f #f)]))
-                 (define (fmt-dots? x)
-                   (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
-                      dots))
-                 (define (fmt-tab x)
-                   (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
-                      tab))
-                 (define (sub-fmt x)
-                   (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
-                      subfmt))
-                 (define (skip-fmt x)
-                   (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
-                      fmt)))
-               ;(import M)
-               (define (boxify/fmt fmt x) 
+                     [(and (pair? fmt) (unshared-list? x))
+                      (boxify-list x 
+                        (if (eq? (car fmt) 'alt)
+                            (cdr fmt)
+                            (list fmt)))]
+                     [else (boxify x)]))
+                 (define (read-macro? x)
+                   (and (pair? x) (eq? (car x) 'read-macro)))
                  (cond
-                   [(and (pair? fmt) (pair? x) (list? x))
-                    (boxify-list x 
-                      (if (eq? (car fmt) 'alt)
-                          (cdr fmt)
-                          (list fmt)))]
-                   [else (boxify x)]))
-               (define (read-macro? x)
-                 (and (pair? x) (eq? (car x) 'read-macro)))
-               (cond
-                 [(read-macro? fmt) 
-                  (conc (cdr fmt) (boxify (cadr ls)))]
-                 [(fmt-dots? fmt) 
-                  (return (fmt-tab fmt) 
-                          (map1ltr (lambda (x) (boxify/fmt (sub-fmt fmt) x))
-                               ls))]
-                 [else
-                  (let-values ([(sep* ls)
-                                (let f ([fmt (skip-fmt fmt)] [ls (cdr ls)])
-                                  (cond
-                                    [(null? ls) 
-                                     (values '() '())]
-                                    [(fmt-dots? fmt) 
-                                     (values (fmt-tab fmt) 
-                                             (map1ltr (lambda (x)
+                   [(read-macro? fmt) 
+                    (conc (cdr fmt) (boxify (cadr ls)))]
+                   [(fmt-dots? fmt) 
+                    (return (fmt-tab fmt) 
+                            (map1ltr (lambda (x) (boxify/fmt (sub-fmt fmt) x))
+                                 ls))]
+                   [else
+                    (let ([a (boxify/fmt (sub-fmt fmt) a)])
+                      (let-values ([(sep* ls)
+                                    (let f ([fmt (skip-fmt fmt)] [ls (cdr ls)])
+                                      (cond
+                                        [(null? ls) 
+                                         (values '() '())]
+                                        [(fmt-dots? fmt) 
+                                         (values (fmt-tab fmt) 
+                                                 (map1ltr
+                                                   (lambda (x)
                                                     (boxify/fmt (sub-fmt fmt) x))
-                                                  ls))]
-                                    [else
-                                     (let-values ([(f^ l^) 
-                                                   (f (skip-fmt fmt) (cdr ls))])
-                                       (values (cons (fmt-tab fmt) f^)
-                                               (cons (boxify/fmt
-                                                       (sub-fmt fmt)
-                                                       (car ls))
-                                                     l^)))]))])
-                    (return sep* (cons (boxify/fmt (sub-fmt fmt) a) ls)))])))]
-            [else 
-             (return (gensep*-default ls) (map1ltr boxify ls))])))
+                                                   ls))]
+                                        [else
+                                         (let ([a 
+                                                (boxify/fmt (sub-fmt fmt)
+                                                  (car ls))])
+                                           (let-values ([(f^ l^) 
+                                                         (f (skip-fmt fmt)
+                                                            (cdr ls))])
+                                             (values (cons (fmt-tab fmt) f^)
+                                                     (cons a l^))))]))])
+                        (return sep* (cons a ls))))])))]
+              [else 
+               (return (gensep*-default ls) (map1ltr boxify ls))])))
+      (boxify-list ls '()))
     (define (boxify-pair x)
-      (let-values ([(ls last)
-                    (let f ([x x])
-                      (cond
-                        [(pair? x)
-                         (let ([a (boxify (car x))])
-                           (let-values ([(ls last) (f (cdr x))])
-                             (values (cons a ls) last)))]
-                        [else
-                         (values '() (boxify x))]))])
-        (let ([n 
-               (let f ([ls ls] [n 4])
-                 (cond
-                   [(null? ls) n]
-                   [else 
-                    (f (cdr ls) 
-                       (fx+ (fxadd1 n) (box-length (car ls))))]))])
-          (make-pbox (fx+ n (box-length last)) ls last))))
+      (define (boxify-cdrs x)
+        (cond
+          [(and (pair? x) (not (graphed? x)))
+           (let ([a (boxify (car x))])
+             (let-values ([(ls last) (boxify-cdrs (cdr x))])
+               (values (cons a ls) last)))]
+          [else
+           (values '() (boxify x))]))
+      (let ([a (boxify (car x))])
+        (let-values ([(ls last) (boxify-cdrs (cdr x))])
+          (let ([ls (cons a ls)])
+            (let ([n 
+                   (let f ([ls ls] [n 4])
+                     (cond
+                       [(null? ls) n]
+                       [else 
+                        (f (cdr ls) 
+                           (fx+ (fxadd1 n) (box-length (car ls))))]))])
+              (make-pbox (fx+ n (box-length last)) ls last))))))
     (define (boxify-vector x)
       (let ([ls (map1ltr boxify (vector->list x))])
         (let ([n
@@ -217,19 +225,104 @@
                    [(null? ls) n]
                    [else
                     (f (cdr ls) (fx+ n (box-length (car ls))))]))])
-          (make-vbox (fx+ (fx+ n 2) (vector-length x)) ls))))
-    (cond
-      [(null? x)      "()"]
-      [(vector? x)    (boxify-vector x)]
-      [(list? x)      (boxify-list x '())]
-      [(pair? x)      (boxify-pair x)]
-      [(setbox? x) 
-       (let ([i (format "#~a=" (setbox-idx x))]
-             [b (boxify (setbox-data x))])
-         (make-cbox (+ (string-length i) (box-length b))
-           (list i b)))]
-      [(refbox? x) (format "#~a#" (refbox-idx x))]
-      [else           (format "~s" x)]))
+          (make-vbox (fx+ (fx+ n 2) (vector-length x)) "#" ls))))
+    (define (boxify-bytevector x)
+      (define prefix "#vu8")
+      (let ([ls (map (lambda (x) (number->string x))
+                       (bytevector->u8-list x))])
+        (let ([len (fold-left (lambda (ac s) (+ 1 ac (string-length s))) 
+                              (+ 1 (string-length prefix))
+                              ls)])
+          (make-vbox len prefix ls))))
+    (define (graphed? x) 
+      (import traversal-helpers)
+      (let ([b (hashtable-ref h x #f)])
+        (let ([b (if (fixnum? b) b (car b))])
+          (cond
+            [(cyclic-set? b) #t]
+            [(shared-set? b) (print-graph)]
+            [else            #f]))))
+    (define (unshared-list? x)
+      ;;; all cdrs of non-empty list are not-shared?
+      (and (pair? x)
+           (let f ([x (cdr x)])
+             (or (null? x)
+                 (and (pair? x)
+                      (not (graphed? x))
+                      (f (cdr x)))))))
+    (define (boxify-struct x)
+      (define (boxify-vanilla-struct x)
+        (cond
+          [(let ([rtd (struct-type-descriptor x)])
+             (and (record-type-descriptor? rtd) 
+                  (record-type-opaque? rtd)))
+           "#<unknown>"]
+          [else
+           (let* ([name (boxify (struct-name x))]
+                  [ls 
+                   (let ([n (struct-length x)])
+                     (let f ([i 0])
+                       (cond
+                         [(fx= i n) '()]
+                         [else 
+                          (let ([a (boxify (struct-ref x i))])
+                            (cons a (f (+ i 1))))])))]
+                  [ls (cons name ls)]
+                  [len (fold-left (lambda (ac s) (+ 1 ac (box-length s)))
+                                 -1 ls)])
+              (conc "#[" (make-fbox len ls #f) "]"))]))
+      (define (boxify-custom-struct out)
+        (import traversal-helpers)
+        (let ([ls 
+               (let f ([cache (cdr out)])
+                 (cond
+                   [(not cache) (list (car out))]
+                   [else
+                    (let ([obj (boxify (cache-object cache))])
+                      (let ([ls (f (cache-next cache))])
+                        (cons* (cache-string cache) obj ls)))]))])
+          (let ([len (fold-left (lambda (ac s) (+ 1 ac (box-length s)))
+                                 -1 ls)])
+            (make-fbox len ls #f))))
+      (let ([b (hashtable-ref h x #f)])
+        (cond
+          [(pair? b) (boxify-custom-struct (cdr b))]
+          [else (boxify-vanilla-struct x)])))
+    (define (boxify-shared x k)
+      (import traversal-helpers)
+      (let ([b (hashtable-ref h x #f)])
+        (let ([b (if (fixnum? b) b (car b))])
+          (cond
+            [(mark-set? b)
+             (string-append "#" 
+                (number->string (fxsra b mark-shift)) 
+                "#")]
+            [(or (cyclic-set? b) 
+                 (and (shared-set? b) (print-graph)))
+             (let ([n shared-idx])
+               (set! shared-idx (+ shared-idx 1))
+               (set-mark! x h n)
+               (let ([str (string-append "#" (number->string n) "=")])
+                 (let ([xbox (k x)])
+                   (make-cbox (+ (string-length str) (box-length xbox))
+                     (list str xbox)))))]
+            [else (k x)]))))
+    (define (boxify x)
+      (cond
+        [(null? x)          "()"]
+        [(vector? x)        (boxify-shared x boxify-vector)]
+        [(unshared-list? x) (boxify-shared x boxify-list)]
+        [(pair? x)          (boxify-shared x boxify-pair)]
+        [(bytevector? x)    (boxify-shared x boxify-bytevector)]
+        [(struct? x)        (boxify-shared x boxify-struct)]
+        ;[(setbox? x) 
+        ; (let ([i (format "#~a=" (setbox-idx x))]
+        ;       [b (boxify (setbox-data x))])
+        ;   (make-cbox (+ (string-length i) (box-length b))
+        ;     (list i b)))]
+        ;[(refbox? x) (format "#~a#" (refbox-idx x))]
+        [else           (format "~s" x)]))
+    (boxify x))
   (define string-esc-table
     '((7 . "a")
       (8 . "b")
@@ -244,7 +337,7 @@
     (cond
       [(fx< n 10) (integer->char (fx+ n (char->integer #\0)))]
       [else (integer->char (fx+ (fx- n 10) (char->integer #\A)))]))
-  (define (output x p) 
+  (define (output x p)
     (define (output-cbox x p col)
       (let g ([ls (cbox-boxes x)] [p p] [col col])
         (cond
@@ -317,16 +410,17 @@
       (display (mbox-str x) p)
       (f (mbox-val x) p (fx+ col (string-length (mbox-str x)))))
     (define (output-vbox x p col)
-      (let ([ls (vbox-ls x)])
+      (display (vbox-prefix x) p)
+      (let ([ls (vbox-ls x)] [col (+ col (string-length (vbox-prefix x)))])
         (cond
           [(null? ls)
-           (display "#()" p)
-           (fx+ col 3)]
+           (display "()" p)
+           (fx+ col 2)]
           [else
-           (display "#(" p)
+           (display "(" p)
            (let g ([ls (cdr ls)] [p p]
-                   [col (f (car ls) p (fx+ col 2))]
-                   [start (fx+ col 2)])
+                   [col (f (car ls) p (fx+ col 1))]
+                   [start (fx+ col 1)])
              (cond
                [(null? ls)
                 (display ")" p)
@@ -443,13 +537,9 @@
             [else
              (let ([col (f box p left)])
                (output-rest-multi box* sep* p col left))])))
-      (display "(" p)
-      (let ([col (fx+ col 1)]
-            [box* (fbox-box* x)]
+      (let ([box* (fbox-box* x)]
             [sep* (fbox-sep* x)])
-        (let ([col (output-box-init (car box*) (cdr box*) sep* p col)])
-          (display ")" p)
-          (fx+ col 1))))
+        (output-box-init (car box*) (cdr box*) sep* p col)))
     (define (f x p col)
       (cond
         [(string? x) 
@@ -465,140 +555,10 @@
     (newline p))
   ;;;
   
-  (define (hasher x h)
-    (define (vec-graph x i j)
-      (unless (fx= i j)
-        (graph (vector-ref x i))
-        (vec-graph x (fxadd1 i) j)))
-    (define (vec-dynamic x i j)
-      (unless (fx= i j)
-        (dynamic (vector-ref x i))
-        (vec-dynamic x (fxadd1 i) j)))
-    (define rv #f)
-    (define (graph x)
-      (cond
-        [(pair? x)
-         (cond
-           [(hashtable-ref h x #f) =>
-            (lambda (n)
-              (set! rv #t)
-              (hashtable-set! h x (fxadd1 n)))]
-           [else
-            (hashtable-set! h x 0)
-            (graph (car x))
-            (graph (cdr x))])]
-        [(vector? x)
-         (cond
-           [(hashtable-ref h x #f) =>
-            (lambda (n)
-              (set! rv #t)
-              (hashtable-set! h x (fxadd1 n)))]
-           [else
-            (hashtable-set! h x 0)
-            (vec-graph x 0 (vector-length x))])]
-        [(gensym? x)
-         (cond
-           [(hashtable-ref h x #f) =>
-            (lambda (n)
-              (set! rv #t)
-              (hashtable-set! h x (fxadd1 n)))])]))
-    (define (dynamic x)
-      (cond
-        [(pair? x)
-         (cond
-           [(hashtable-ref h x #f) =>
-            (lambda (n)
-              (set! rv #t)
-              (hashtable-set! h x (fxadd1 n)))]
-           [else
-            (hashtable-set! h x 0)
-            (dynamic (car x))
-            (dynamic (cdr x))
-            (when (and (hashtable-ref h x #f)
-                       (fxzero? (hashtable-ref h x #f)))
-              (hashtable-set! h x #f))])]
-        [(vector? x)
-         (cond
-           [(hashtable-ref h x #f) =>
-            (lambda (n)
-              (set! rv #t)
-              (hashtable-set! h x (fxadd1 n)))]
-           [else
-            (hashtable-set! h x 0)
-            (vec-dynamic x 0 (vector-length x))
-            (when (and (hashtable-ref h x #f)
-                       (fxzero? (hashtable-ref h x #f)))
-              (hashtable-set! h x #f))])])) 
-    (if (print-graph) 
-        (graph x)
-        (dynamic x))
-    rv)
-  
-  (define-struct setbox (idx data))
-  (define-struct refbox (idx))
-  
-  (define (rewrite-shared x h)
-    (define counter 0)
-    (let f ([x x])
-      (cond
-        [(pair? x) 
-         (cond
-           [(hashtable-ref h x #f) =>
-            (lambda (n) 
-              (cond
-                [(setbox? n)
-                 (make-refbox (setbox-idx n))] 
-                [(and (fixnum? n) (fx> n 0))
-                 (let ([box (make-setbox counter #f)])
-                   (set! counter (add1 counter))
-                   (hashtable-set! h x box)
-                   (let* ([a (f (car x))]
-                          [d (f (cdr x))])
-                     (set-setbox-data! box (cons a d))
-                     box))]
-                [else
-                 (let* ([a (f (car x))]
-                        [d (f (cdr x))])
-                   (if (and (eq? a (car x))
-                            (eq? d (cdr x)))
-                       x
-                       (cons a d)))]))]
-           [else
-            (let* ([a (f (car x))]
-                   [d (f (cdr x))])
-              (if (and (eq? a (car x))
-                       (eq? d (cdr x)))
-                  x
-                  (cons a d)))])]
-        [(vector? x)
-         (cond
-           [(hashtable-ref h x #f) =>
-            (lambda (n) 
-              (cond
-                [(setbox? n)
-                 (make-refbox (setbox-idx n))]
-                [(and (fixnum? n) (fx> n 0))
-                 (let ([box (make-setbox counter #f)])
-                   (set! counter (add1 counter))
-                   (hashtable-set! h x box)
-                   (set-setbox-data! box
-                     (list->vector
-                       (map1ltr f (vector->list x))))
-                   box)]
-                [else 
-                 (list->vector (map1ltr f (vector->list x)))]))]
-           [else
-            (list->vector (map1ltr f (vector->list x)))])]
-        [else x])))
-  
-  (define (unshare x) 
+  (define (pretty x p) 
     (let ([h (make-eq-hashtable)])
-      (if (hasher x h)
-          (rewrite-shared x h)
-          x)))
-  ;;;
-  (define (pretty x p)
-    (output (boxify (unshare x)) p))
+      (traverse x h)
+      (output (boxify x h) p)))
   ;;;
   (define pretty-print 
     (case-lambda
diff --git a/scheme/ikarus.writer.ss b/scheme/ikarus.writer.ss
index f28cfb2..6f9a655 100644
--- a/scheme/ikarus.writer.ss
+++ b/scheme/ikarus.writer.ss
@@ -17,7 +17,8 @@
 (library (ikarus writer)
 
   (export write display format printf fprintf print-error
-          print-unicode print-graph put-datum traverse)
+          print-unicode print-graph put-datum traverse
+          traversal-helpers)
 
   (import 
     (rnrs hashtables)
@@ -39,42 +40,57 @@
     (make-parameter #t))
 
 
-;;; association list in hash table is one of the following forms:
-;;;
-;;; a fixnum: 
-(define cyclic-bit         #b001)
-(define shared-bit         #b010)
-(define marked-bit         #b100)
-(define mark-shift         3)
-;;;
-;;; or a pair of a fixnum (above) and a cache:
-(define-struct cache (string object next))
-(define (cyclic-set? b) 
-  (fx= (fxand b cyclic-bit) cyclic-bit))
-(define (shared-set? b)
-  (fx= (fxand b shared-bit) shared-bit))
-(define (mark-set? b)
-  (fx= (fxand b marked-bit) marked-bit))
-             
-(define (set-mark! x h n)
-  (let ([b (hashtable-ref h x #f)])
-    (cond
-      [(fixnum? b) 
-       (hashtable-set! h x 
-         (fxior (fxsll n mark-shift) marked-bit b))]
-      [else
-       (set-car! b 
-         (fxior (fxsll n mark-shift) marked-bit (car b)))])))
+(module traversal-helpers
+  (cyclic-set? shared-set? mark-set? set-mark! set-shared! shared?
+               shared-bit cyclic-bit marked-bit mark-shift
+               make-cache cache-string cache-object cache-next)
+  ;;; association list in hash table is one of the following forms:
+  ;;;
+  ;;; a fixnum: 
+  (define cyclic-bit         #b001)
+  (define shared-bit         #b010)
+  (define marked-bit         #b100)
+  (define mark-shift         3)
+  ;;;
+  ;;; or a pair of a fixnum (above) and a cache:
+  (define-struct cache (string object next))
+  (define (cyclic-set? b) 
+    (fx= (fxand b cyclic-bit) cyclic-bit))
+  (define (shared-set? b)
+    (fx= (fxand b shared-bit) shared-bit))
+  (define (mark-set? b)
+    (fx= (fxand b marked-bit) marked-bit))
+               
+  (define (set-mark! x h n)
+    (let ([b (hashtable-ref h x #f)])
+      (cond
+        [(fixnum? b) 
+         (hashtable-set! h x 
+           (fxior (fxsll n mark-shift) marked-bit b))]
+        [else
+         (set-car! b 
+           (fxior (fxsll n mark-shift) marked-bit (car b)))])))
+
+  (define (set-shared! x h)
+    (let ([b (hashtable-ref h x #f)])
+      (cond
+        [(fixnum? b) 
+         (hashtable-set! h x (fxior shared-bit b))]
+        [else
+         (set-car! b (fxior shared-bit (car b)))])))
+  
+  (define (shared? x h)
+    (cond
+      [(hashtable-ref h x #f) =>
+       (lambda (b) 
+         (if (fixnum? b) 
+             (shared-set? b)
+             (let ([b (car b)])
+               (shared-set? b))))]
+      [else #f])))
+(import traversal-helpers)
+
 
-(define (shared? x h)
-  (cond
-    [(hashtable-ref h x #f) =>
-     (lambda (b) 
-       (if (fixnum? b) 
-           (shared-set? b)
-           (let ([b (car b)])
-             (shared-set? b))))]
-    [else #f]))
 (define (cannot-happen)
   (error 'ikarus-writer "internal error"))
 
diff --git a/scheme/last-revision b/scheme/last-revision
index 0e1b3bc..4ef9b1f 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1627
+1628