diff --git a/Makefile b/Makefile
index 60cee00f..3ef5804f 100644
--- a/Makefile
+++ b/Makefile
@@ -251,7 +251,7 @@ install: all
 	$(INSTALL) chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
 	$(INSTALL) tools/chibi-ffi $(DESTDIR)$(BINDIR)/
 	$(INSTALL) tools/chibi-doc $(DESTDIR)$(BINDIR)/
-	$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/term
+	$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/term
 	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
 	$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
 	$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
@@ -266,6 +266,7 @@ install: all
 	$(INSTALL) lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
 	$(INSTALL) lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
 	$(INSTALL) lib/chibi/parse/*.sld lib/chibi/parse/*.scm $(DESTDIR)$(MODDIR)/chibi/parse/
+	$(INSTALL) lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
 	$(INSTALL) lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
 	$(INSTALL) lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
 	$(INSTALL) lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
@@ -326,6 +327,7 @@ uninstall:
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(BINMODDIR)/chibi/parse
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
diff --git a/lib/chibi/show.sld b/lib/chibi/show.sld
new file mode 100644
index 00000000..04b2dcb9
--- /dev/null
+++ b/lib/chibi/show.sld
@@ -0,0 +1,13 @@
+
+(define-library (chibi show)
+  (export
+   show fn fn-fork with update! each each-in-list call-with-output
+   displayed written written-shared written-simply numeric nothing
+   nl fl space-to tab-to
+   padded padded/left padded/right padded/both
+   trimmed trimmed/left trimmed/right trimmed/both trimmed/lazy
+   fitted fitted/left fitted/right fitted/both
+   joined joined/prefix joined/suffix joined/last joined/dot
+   upcased downcased)
+  (import (scheme base) (scheme char) (chibi show base) (scheme write))
+  (include "show/show.scm"))
diff --git a/lib/chibi/show/base.scm b/lib/chibi/show/base.scm
new file mode 100644
index 00000000..28508ee5
--- /dev/null
+++ b/lib/chibi/show/base.scm
@@ -0,0 +1,175 @@
+;; base.scm - base formatting monad
+;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> A library of procedures for formatting Scheme objects to text in
+;;> various ways, and for easily concatenating, composing and
+;;> extending these formatters efficiently without resorting to
+;;> capturing and manipulating intermediate strings.
+
+;;> \section{Background}
+;;>
+;;> There are several approaches to text formatting.  Building strings to
+;;> \q{display} is not acceptable, since it doesn't scale to very large
+;;> output.  The simplest realistic idea, and what people resort to in
+;;> typical portable Scheme, is to interleave \q{display} and \q{write}
+;;> and manual loops, but this is both extremely verbose and doesn't
+;;> compose well.  A simple concept such as padding space can't be
+;;> achieved directly without somehow capturing intermediate output.
+;;>
+;;> The traditional approach is to use templates - typically strings,
+;;> though in theory any object could be used and indeed Emacs' mode-line
+;;> format templates allow arbitrary sexps.  Templates can use either
+;;> escape sequences (as in C's \q{printf} and \urlh{#BIBITEM_2}{CL's}
+;;> \q{format}) or pattern matching (as in Visual Basic's \q{Format},
+;;> \urlh{#BIBITEM_6}{Perl6's} \q{form}, and SQL date formats).  The
+;;> primary disadvantage of templates is the relative difficulty (usually
+;;> impossibility) of extending them, their opaqueness, and the
+;;> unreadability that arises with complex formats.  Templates are not
+;;> without their advantages, but they are already addressed by other
+;;> libraries such as \urlh{#BIBITEM_3}{SRFI-28} and
+;;> \urlh{#BIBITEM_4}{SRFI-48}.
+;;>
+;;> This library takes a combinator approach.  Formats are nested chains
+;;> of closures, which are called to produce their output as needed.
+;;> The primary goal of this library is to have, first and foremost, a
+;;> maximally expressive and extensible formatting library.  The next
+;;> most important goal is scalability - to be able to handle
+;;> arbitrarily large output and not build intermediate results except
+;;> where necessary.  The third goal is brevity and ease of use.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The environment monad with some pre-defined fields for combinator
+;; formatting.
+
+(define-environment-monad Show-Env
+  (sequence: sequence)
+  (bind: fn)
+  (bind-fork: fn-fork)
+  (local: %with)
+  (local!: update!)
+  (return: return)
+  (run: run)
+  ;; These are never used directly, but we must provide the names to
+  ;; preserve hygiene.
+  (ask: ask %ask)
+  (tell: tell %tell)
+  (copy: copy)
+  (fields:
+   (port env-port env-port-set!)
+   (row env-row env-row-set!)
+   (col env-col env-col-set!)
+   (width env-width env-width-set!)
+   (radix env-radix env-radix-set!)
+   (precision env-precision env-precision-set!)
+   (pad-char env-pad-char env-pad-char-set!)
+   (decimal-sep env-decimal-sep env-decimal-sep-set!)
+   (decimal-align env-decimal-align env-decimal-align-set!)
+   (string-width env-string-width env-string-width-set!)
+   (ellipsis env-ellipsis env-ellipsis-set!)
+   (writer env-writer env-writer-set!)
+   (output env-output env-output-set!)))
+
+(define-syntax with
+  (syntax-rules ()
+    ((with params x) (%with params (displayed x)))
+    ((with params . x) (%with params (each . x)))))
+
+;; The base formatting handles outputting raw strings and a simple,
+;; configurable handler for formatting objects.
+
+;; Utility - default value of string-width.
+(define (substring-length str . o)
+  (let ((start (if (pair? o) (car o) 0))
+        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
+    (- end start)))
+
+;; Raw output - displays str to the formatter output port and updates
+;; row and col.
+(define (output-default str)
+  (fn (port row col string-width)
+    (display str port)
+    (let ((nl-index (string-find-right str #\newline)))
+      (if (> nl-index 0)
+          (update! (row (+ row (string-count str #\newline)))
+                   (col (string-width str nl-index)))
+          (update! (col (+ col (string-width str))))))))
+
+;; Raw output.  All primitive output should go through this operation.
+;; Overridable, defaulting to output-default.
+(define (output str)
+  (fn (output) ((or output output-default) str)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> The primary interface.  Analogous to CL's \scheme{format}, the first
+;;> argument is either an output port or a boolean, with \scheme{#t}
+;;> indicating \scheme{current-output-port} and \scheme{#f} indicating a
+;;> string port.  The remaining arguments are formatters, combined as with
+;;> \scheme{each}, run with output to the given destination.  If \var{out}
+;;> is \scheme{#f} then the accumulated output is returned, otherwise
+;;> the result is unspecified.
+(define (show out . args)
+  (let ((proc (each-in-list args)))
+    (cond
+     ((output-port? out)
+      (show-run out proc))
+     ((eq? #t out)
+      (show-run (current-output-port) proc))
+     ((eq? #f out)
+      (let ((out (open-output-string)))
+        (show-run out proc) 
+        (get-output-string out)))
+     (else
+      (error "unknown output to show" out)))))
+
+;; Run with an output port with initial default values.
+(define (show-run out proc)
+  (run (sequence (update! (port out)
+                          (col 0)
+                          (row 0)
+                          (width 78)
+                          (radix 10)
+                          (pad-char #\space)
+                          (output output-default)
+                          (string-width substring-length))
+                 proc)))
+
+;;> Captures the output of \var{producer} and formats the result with
+;;> \var{consumer}.
+(define (call-with-output producer consumer)
+  (let ((out (open-output-string)))
+    (fn-fork (with ((port out)) producer)
+             (fn () (consumer (get-output-string out))))))
+
+;;> The noop formatter.  Generates no output and leaves the state
+;;> unmodified.
+(define nothing (fn () (update!)))
+
+;;> Formats a displayed version of x - if a string or char, outputs the
+;;> raw characters (as with `display'), if x is already a formatter
+;;> defers to that, otherwise outputs a written version of x.
+(define (displayed x)
+  (cond
+   ((procedure? x) x)
+   ((string? x) (output x))
+   ((char? x) (output (string x)))
+   (else (written x))))
+
+;;> Formats a written version of x, as with `write'.  The formatting
+;;> can be updated with the \scheme{'writer} field.
+(define (written x)
+  (fn (writer) ((or writer written-default) x)))
+
+;;> Takes a single list of formatters, combined in sequence with
+;;> \scheme{each}.
+(define (each-in-list args)
+  (if (pair? args)
+      (sequence (displayed (car args)) (each-in-list (cdr args)))
+      nothing))
+
+;;> Combines each of the formatters in a sequence using
+;;> \scheme{displayed}, so that strings and chars will be output
+;;> directly and other objects will be \scheme{written}.
+(define (each . args)
+  (each-in-list args))
diff --git a/lib/chibi/show/base.sld b/lib/chibi/show/base.sld
new file mode 100644
index 00000000..841b4514
--- /dev/null
+++ b/lib/chibi/show/base.sld
@@ -0,0 +1,10 @@
+
+(define-library (chibi show base)
+  (export
+   show fn fn-fork with update! each each-in-list call-with-output
+   displayed written written-shared written-simply numeric nothing
+   output-default)
+  (import (scheme base) (scheme write) (scheme complex) (scheme inexact)
+          (srfi 1) (srfi 69) (chibi string) (chibi monad environment))
+  (include "base.scm")
+  (include "write.scm"))
diff --git a/lib/chibi/show/show.scm b/lib/chibi/show/show.scm
new file mode 100644
index 00000000..48ce8d1d
--- /dev/null
+++ b/lib/chibi/show/show.scm
@@ -0,0 +1,195 @@
+;; show.scm -- additional combinator formatters
+;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Spacing
+
+;;> Output a single newline.
+(define nl (displayed "\n"))
+
+;;> "Fresh line" - output a newline iff we're not at the start of a
+;;> fresh line.
+(define fl
+  (fn (col) (if (zero? col) nothing nl)))
+
+;;> Move to a given tab-stop (using spaces, not tabs).
+(define (tab-to . o)
+  (fn (col pad-char)
+    (let* ((tab-width (if (pair? o) (car o) 8))
+           (rem (modulo col tab-width)))
+      (if (positive? rem)
+          (displayed (make-string (- tab-width rem) pad-char))
+          nothing))))
+
+;;> Move to an explicit column.
+(define (space-to where)
+  (fn (col pad-char)
+    (displayed (make-string (max 0 (- where col)) pad-char))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; String transformations
+
+(define (with-string-transformer proc . ls)
+  (fn (output)
+    (let ((output* (lambda (str) (fn () (output (proc str))))))
+      (with ((output output*)) (each-in-list ls)))))
+
+(define (upcased . ls) (apply with-string-transformer string-upcase ls))
+(define (downcased . ls) (apply with-string-transformer string-downcase ls))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Padding and trimming
+
+(define (padded/both width . ls)
+  (call-with-output
+   (each-in-list ls)
+   (lambda (str)
+     (fn (string-width pad-char)
+       (let ((diff (- width (string-width str))))
+         (if (positive? diff)
+             (let* ((diff/2 (quotient diff 2))
+                    (left (make-string diff/2 pad-char))
+                    (right (if (even? diff)
+                               left
+                               (make-string (+ 1 diff/2) pad-char))))
+               (each right str left))
+             (displayed str)))))))
+
+(define (padded width . ls)
+  (fn ((col1 col))
+    (each (each-in-list ls)
+          (fn ((col2 col) pad-char)
+            (displayed (make-string (max 0 (- width (- col2 col1)))
+                                    pad-char))))))
+
+(define padded/right padded)
+
+(define (padded/left width . ls)
+  (call-with-output
+   (each-in-list ls)
+   (lambda (str)
+     (fn (string-width pad-char)
+       (let ((diff (- width (string-width str))))
+         (each (make-string diff pad-char) str))))))
+
+;; General buffered trim - capture the output apply a trimmer.
+(define (trimmed/buffered width producer proc)
+  (call-with-output
+   producer
+   (lambda (str)
+     (fn (string-width)
+       (let* ((str-width (string-width str))
+              (diff (- str-width width)))
+         (displayed (if (positive? diff)
+                        (proc str str-width diff)
+                        str)))))))
+
+(define (trimmed width . ls)
+  (trimmed/buffered
+   width
+   (each-in-list ls)
+   (lambda (str str-width diff)
+     (fn (ellipsis string-width col)
+       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
+              (ell-len (string-width ell))
+              (diff (- (+ str-width ell-len) width)))
+         (each (if (negative? diff)
+                   nothing
+                   (substring str 0 (- width ell-len)))
+               ell))))))
+
+(define trimmed/right trimmed)
+
+(define (trimmed/left width . ls)
+  (trimmed/buffered
+   width
+   (each-in-list ls)
+   (lambda (str str-width diff)
+     (fn (ellipsis string-width)
+       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
+              (ell-len (string-width ell))
+              (diff (- (+ str-width ell-len) width)))
+         (each ell
+               (if (negative? diff)
+                   nothing
+                   (substring str diff))))))))
+
+(define (trimmed/both width . ls)
+  (trimmed/buffered
+   width
+   (each-in-list ls)
+   (lambda (str str-width diff)
+     (fn (ellipsis string-width)
+       (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
+              (ell-len (string-width ell))
+              (diff (- (+ str-width ell-len ell-len) width))
+              (left (quotient diff 2))
+              (right (- (string-width str) (quotient (+ diff 1) 2))))
+         (if (negative? diff)
+             ell
+             (each ell (substring str left right) ell)))))))
+
+(define (trimmed/lazy width . ls)
+  (fn (orig-output string-width)
+    (call-with-current-continuation
+     (lambda (return)
+       (let ((chars-written 0)
+             (output (or orig-output output-default)))
+         (define (output* str)
+           (let ((len (string-width str)))
+             (set! chars-written (+ chars-written len))
+             (if (> chars-written width)
+                 (let* ((end (max 0 (- len (- chars-written width))))
+                        (s (substring str 0 end)))
+                   (each (output s)
+                         (update! (output orig-output))
+                         (fn () (return nothing))))
+                 (output str))))
+         (with ((output output*))
+           (each-in-list ls)))))))
+
+(define (fitted width . ls)
+  (padded width (trimmed width (each-in-list ls))))
+(define fitted/right fitted)
+(define (fitted/left width . ls)
+  (padded/left width (trimmed/left width (each-in-list ls))))
+(define (fitted/both width . ls)
+  (padded/both width (trimmed/both width (each-in-list ls))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Joining and interspersing
+
+(define (joined/general elt-f last-f dot-f init-ls sep)
+  (fn ()
+    (let lp ((ls init-ls))
+      (cond
+       ((pair? ls)
+        (each (if (eq? ls init-ls) nothing sep)
+              ((if (and last-f (null? (cdr ls))) last-f elt-f) (car ls))
+              (lp (cdr ls))))
+       ((and dot-f (not (null? ls)))
+        (each (if (eq? ls init-ls) nothing sep) (dot-f ls)))
+       (else
+        nothing)))))
+
+(define (joined elt-f ls . o)
+  (joined/general elt-f #f #f ls (if (pair? o) (car o) "")))
+
+(define (joined/prefix elt-f ls . o)
+  (if (null? ls)
+      nothing
+      (let ((sep (if (pair? o) (car o) "")))
+        (each sep (joined elt-f ls sep)))))
+
+(define (joined/suffix elt-f ls . o)
+  (if (null? ls)
+      nothing
+      (let ((sep (if (pair? o) (car o) "")))
+        (each (joined elt-f ls sep) sep))))
+
+(define (joined/last elt-f last-f ls . o)
+  (joined/general elt-f last-f #f ls (if (pair? o) (car o) "")))
+
+(define (joined/dot elt-f dot-f ls . o)
+  (joined/general elt-f #f dot-f ls (if (pair? o) (car o) "")))
diff --git a/lib/chibi/show/write.scm b/lib/chibi/show/write.scm
new file mode 100644
index 00000000..7114a412
--- /dev/null
+++ b/lib/chibi/show/write.scm
@@ -0,0 +1,374 @@
+;; write.scm - written formatting, the default displayed for non-string/chars
+;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utils
+
+(define (write-to-string x)
+  (let ((out (open-output-string)))
+    (write x out)
+    (get-output-string out)))
+
+(define (string-replace-all str ch1 ch2)
+  (let ((out (open-output-string)))
+    (string-for-each
+     (lambda (ch) (write-char (if (eqv? ch ch1) ch2 ch) out))
+     str)
+    (get-output-string out)))
+
+(define (string-intersperse-right str sep rule)
+  (let lp ((i (string-length str))
+           (rule rule)
+           (res '()))
+    (let* ((offset (if (pair? rule) (car rule) rule))
+           (i2 (if offset (- i offset) 0)))
+      (if (<= i2 0)
+          (apply string-append (cons (substring str 0 i) res))
+          (lp i2
+              (if (pair? rule) (cdr rule) rule)
+              (cons sep (cons (substring str i2 i) res)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; numeric formatting
+
+(define (char-mirror c)
+  (case c ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else c)))
+
+(define (integer-log a base)
+  (if (zero? a)
+      0
+      (exact (ceiling (/ (log (+ a 1)) (log base))))))
+
+;; The original fmt algorithm was based on "Printing Floating-Point
+;; Numbers Quickly and Accurately" by Burger and Dybvig
+;; (FP-Printing-PLDI96.pdf).  It had grown unwieldy with formatting
+;; special cases, so the below is a simplification which tries to rely
+;; on number->string for common cases.
+
+(define (numeric n)
+  (fn (radix precision decimal-sep decimal-align comma-rule comma-sep sign-rule)
+    (let ((dec-sep (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.))))
+      ;; General formatting utilities.
+      (define (get-scale q)
+        (expt radix (- (integer-log q radix) 1)))
+      (define (char-digit d)
+        (cond ((char? d) d)
+              ((< d 10) (integer->char (+ d (char->integer #\0))))
+              (else (integer->char (+ (- d 10) (char->integer #\A))))))
+      (define (digit-value ch)
+        (let ((res (- (char->integer ch) (char->integer #\0))))
+          (if (<= 0 res 9)
+              res
+              ch)))
+      (define (round-up ls)
+        (let lp ((ls ls) (res '()))
+          (cond
+           ((null? ls)
+            (cons 1 res))
+           ((not (number? (car ls)))
+            (lp (cdr ls) (cons (car ls) res)))
+           ((= (car ls) (- radix 1))
+            (lp (cdr ls) (cons 0 res)))
+           (else
+            (append (reverse res) (cons (+ 1 (car ls)) (cdr ls)))))))
+      (define (maybe-round n d ls)
+        (let* ((q (quotient n d))
+               (digit (* 2 (if (>= q radix) (quotient q (get-scale q)) q))))
+          (if (or (> digit radix)
+                  (and (= digit radix)
+                       (let ((prev (find integer? ls)))
+                         (and prev (odd? prev)))))
+              (round-up ls)
+              ls)))
+      (define (maybe-trim-zeros i res)
+        (if (and (not precision) (positive? i))
+            (let lp ((res res))
+              (cond
+               ((and (pair? res) (eqv? 0 (car res))) (lp (cdr res)))
+               ((and (pair? res) (eqv? dec-sep (car res))) (cdr res))
+               (else res)))
+            res))
+      ;; General slow loop to generate digits one at a time, for
+      ;; non-standard radixes or writing rationals with a fixed
+      ;; precision.
+      (define (gen-general n)
+        (let* ((p (exact n))
+               (n (numerator p))
+               (d (denominator p)))
+          (let lp ((n n)
+                   (i (- (integer-log p radix)))
+                   (res '()))
+            (cond
+             ;; Use a fixed precision if specified, otherwise generate
+             ;; 15 decimals.
+             ((if precision (< i precision) (< i 16))
+              (let ((res (if (zero? i)
+                             (cons dec-sep (if (null? res) (cons 0 res) res))
+                             res))
+                    (q (quotient n d)))
+                (cond
+                 ((>= q radix)
+                  (let* ((scale (get-scale q))
+                         (digit (quotient q scale))
+                         (n2 (- n (* d digit scale))))
+                    (lp n2 (+ i 1) (cons digit res))))
+                 (else
+                  (lp (* (remainder n d) radix)
+                      (+ i 1)
+                      (cons q res))))))
+             (else
+              (list->string
+               (map char-digit
+                    (reverse (maybe-round n d (maybe-trim-zeros i res))))))))))
+      ;; Generate a fixed precision decimal result by post-editing the
+      ;; result of string->number.
+      (define (gen-fixed n)
+        (cond
+         ((and (eqv? radix 10) (or (integer? n) (inexact? n)))
+          (let* ((s (number->string n))
+                 (len (string-length s))
+                 (dec (string-find s #\.))
+                 (digits (- len dec)))
+            (cond
+             ((< (string-find s #\e) len)
+              (gen-general n))
+             ((= dec len)
+              (string-append s "." (make-string precision #\0)))
+             ((<= digits precision)
+              (string-append s (make-string (- precision digits -1) #\0)))
+             (else
+              (let* ((last (- len (- digits precision 1)))
+                     (res (substring s 0 last)))
+                (if (and
+                     (< last len)
+                     (let ((next (digit-value (string-ref s last))))
+                       (or (> next 5)
+                           (and (= next 5) (> last 0)
+                                (odd? (digit-value
+                                       (string-ref s (- last 1))))))))
+                    (list->string
+                     (reverse
+                      (map char-digit
+                           (round-up
+                            (reverse (map digit-value (string->list res)))))))
+                    res))))))
+         (else
+          (gen-general n))))
+      ;; Generate any unsigned real number.
+      (define (gen-positive-real n)
+        (cond
+         (precision
+          (gen-fixed n))
+         ((and (exact? n) (not (integer? n)))
+          (string-append (number->string (numerator n) radix)
+                         "/"
+                         (number->string (denominator n) radix)))
+         ((memv radix (if (exact? n) '(2 8 10 16) '(10)))
+          (number->string n))
+         (else
+          (gen-general n))))
+      ;; Insert commas according to the current comma-rule.
+      (define (insert-commas str)
+        (let* ((dec-pos (string-find str dec-sep))
+               (left (substring str 0 dec-pos))
+               (right (substring str dec-pos))
+               (sep (cond ((char? comma-sep) (string comma-sep))
+                          ((string? comma-sep) comma-sep)
+                          ((eqv? #\, dec-sep) ".")
+                          (else ","))))
+          (string-append
+           (string-intersperse-right left sep comma-rule)
+           right)))
+      ;; Post-process a positive real number with decimal char fixup
+      ;; and commas as needed.
+      (define (wrap-comma n)
+        (let* ((s0 (gen-positive-real n))
+               (s1 (if (and (char? dec-sep)
+                            (not (eqv? #\. dec-sep)))
+                       (string-replace-all s0 #\. dec-sep)
+                       s0)))
+          (if comma-rule (insert-commas s1) s1)))
+      ;; Wrap the sign of a real number, forcing a + prefix or using
+      ;; parentheses (n) for negatives according to sign-rule.
+      (define (wrap-sign n sign-rule)
+        (cond
+         ((negative? n)
+          (if (char? sign-rule)
+              (string-append (string sign-rule)
+                             (wrap-comma (abs n))
+                             (string (char-mirror sign-rule)))
+              (string-append "-" (wrap-comma (abs n)))))
+         ((eq? #t sign-rule)
+          (string-append "+" (wrap-comma n)))
+         (else
+          (wrap-comma n))))
+      ;; Format a single real number with padding as necessary.
+      (define (format n sign-rule)
+        (let ((s (wrap-sign n sign-rule)))
+          (let* ((dec-pos (if decimal-align (string-find s dec-sep) 0))
+                 (diff (- (or decimal-align 0) dec-pos 1)))
+            (if (positive? diff)
+                (string-append (make-string diff #\space) s)
+                s))))
+      ;; Write any number.
+      (define (write-complex n)
+        (cond
+         ((and radix (not (and (integer? radix) (<= 2 radix 36))))
+          (error "invalid radix for numeric formatting" radix))
+         ((zero? (imag-part n))
+          (displayed (format (real-part n) sign-rule)))
+         (else
+          (each (format (real-part n) sign-rule)
+                (format (imag-part n) #t)
+                "i"))))
+      (write-complex n))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; shared structure utilities
+
+(define (extract-shared-objects x cyclic-only?)
+  (let ((seen (make-hash-table eq?)))
+    ;; find shared references
+    (let find ((x x))
+      (cond ;; only interested in pairs and vectors (and records later)
+       ((or (pair? x) (vector? x))
+        ;; increment the count
+        (hash-table-update!/default seen x (lambda (n) (+ n 1)) 0)
+        ;; walk if this is the first time
+        (cond
+         ((> (hash-table-ref seen x) 1))
+         ((pair? x)
+          (find (car x))
+          (find (cdr x)))
+         ((vector? x)
+          (do ((i 0 (+ i 1)))
+              ((= i (vector-length x)))
+            (find (vector-ref x i)))))
+        ;; delete if this shouldn't count as a shared reference
+        (if (and cyclic-only? (<= (hash-table-ref/default seen x 0) 1))
+            (hash-table-delete! seen x)))))
+    ;; extract shared references
+    (let ((res (make-hash-table eq?))
+          (count 0))
+      (hash-table-walk
+       seen
+       (lambda (k v)
+         (cond
+          ((> v 1)
+           (hash-table-set! res k (cons count #f))
+           (set! count (+ count 1))))))
+      res)))
+
+(define (maybe-gen-shared-ref cell shares)
+  (cond
+    ((pair? cell)
+     (set-car! cell (cdr shares))
+     (set-cdr! cell #t)
+     (set-cdr! shares (+ (cdr shares) 1))
+     (each "#" (number->string (car cell)) "="))
+    (else nothing)))
+
+(define (call-with-shared-ref obj shares proc)
+  (let ((cell (hash-table-ref/default (car shares) obj #f)))
+    (if (and (pair? cell) (cdr cell))
+        (each "#" (number->string (car cell)) "#")
+        (each (maybe-gen-shared-ref cell shares) proc))))
+
+(define (call-with-shared-ref/cdr obj shares proc)
+  (let ((cell (hash-table-ref/default (car shares) obj #f)))
+    (cond
+      ((and (pair? cell) (cdr cell))
+       (each ". #" (number->string (car cell)) "#"))
+      ((pair? cell)
+       (each ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
+      (else
+       proc))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; written
+
+(define (write-with-shares obj shares)
+  (fn (radix precision)
+    (let ((write-number
+           ;; Shortcut for numeric values.  Try to rely on
+           ;; number->string for standard radixes and no precision,
+           ;; otherwise fall back on numeric but resetting to a usable
+           ;; radix.
+           (cond
+            ((and (not precision)
+                  (assv radix '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))))
+             => (lambda (cell)
+                  (lambda (n)
+                    (if (or (exact? n) (eqv? radix 10))
+                        (each (cdr cell) (number->string n (car cell)))
+                        (with ((radix 10)) (numeric n))))))
+            (else (lambda (n) (with ((radix 10)) (numeric n)))))))
+      ;; `wr' is the recursive writer closing over the shares.
+      (let wr ((obj obj))
+        (call-with-shared-ref
+         obj shares
+         (fn ()
+           (cond
+            ((pair? obj)
+             (each "("
+                   (fn ()
+                     (let lp ((ls obj))
+                       (let ((rest (cdr ls)))
+                         (each (wr (car ls))
+                               (cond
+                                ((null? rest)
+                                 nothing)
+                                ((pair? rest)
+                                 (each
+                                  " "
+                                  (call-with-shared-ref/cdr
+                                   rest shares
+                                   (fn () (lp rest)))))
+                                (else
+                                 (each " . " (wr rest))))))))
+                   ")"))
+            ((vector? obj)
+             (let ((len (vector-length obj)))
+               (if (zero? len)
+                   (displayed "#()")
+                   (each "#("
+                         (wr (vector-ref obj 0))
+                         (fn ()
+                           (let lp ((i 1))
+                             (if (>= i len)
+                                 nothing
+                                 (each " " (wr (vector-ref obj i))
+                                       (fn () (lp (+ i 1)))))))
+                         ")"))))
+            ((number? obj)
+             (write-number obj))
+            (else
+             (displayed (write-to-string obj))))))))))
+
+;; The default formatter for `written', overriden with the `writer'
+;; variable.  Intended to be equivalent to `write', using datum labels
+;; for shared notation iff there are cycles in the object.
+
+(define (written-default obj)
+  (fn ()
+    (write-with-shares obj (cons (extract-shared-objects obj #t) 0))))
+
+;; Writes the object showing the full shared structure.
+
+(define (written-shared obj)
+  (fn ()
+    (write-with-shares obj (cons (extract-shared-objects obj #f) 0))))
+
+;; The only expensive part, in both time and memory, of handling
+;; shared structures when writing is building the initial table, so
+;; for the efficient version we just skip that and re-use the writing
+;; code.
+
+(define (written-simply obj)
+  (fn ()
+    (write-with-shares obj (cons (make-hash-table eq?) 0))))
+
+;; Local variables:
+;; eval: (put 'fn 'scheme-indent-function 1)
+;; End:
diff --git a/tests/show-tests.scm b/tests/show-tests.scm
new file mode 100644
index 00000000..6bf000fe
--- /dev/null
+++ b/tests/show-tests.scm
@@ -0,0 +1,286 @@
+
+(import (scheme base) (chibi show) (chibi test))
+
+(test-begin "show")
+
+;; basic data types
+
+(test "hi" (show #f "hi"))
+(test "\"hi\"" (show #f (written "hi")))
+(test "\"hi \\\"bob\\\"\"" (show #f (written "hi \"bob\"")))
+(test "\"hello\\nworld\"" (show #f (written "hello\nworld")))
+(test "#(1 2 3)" (show #f (written '#(1 2 3))))
+(test "(1 2 3)" (show #f (written '(1 2 3))))
+(test "(1 2 . 3)" (show #f (written '(1 2 . 3))))
+(test "ABC" (show #f (upcased "abc")))
+(test "abc" (show #f (downcased "ABC")))
+
+(test "abc     def" (show #f "abc" (tab-to) "def"))
+(test "abc  def" (show #f "abc" (tab-to 5) "def"))
+(test "abcdef" (show #f "abc" (tab-to 3) "def"))
+
+;; numbers
+
+(test "-1" (show #f -1))
+(test "0" (show #f 0))
+(test "1" (show #f 1))
+(test "10" (show #f 10))
+(test "100" (show #f 100))
+(test "-1" (show #f (numeric -1)))
+(test "0" (show #f (numeric 0)))
+(test "1" (show #f (numeric 1)))
+(test "10" (show #f (numeric 10)))
+(test "100" (show #f (numeric 100)))
+(test "57005" (show #f #xDEAD))
+(test "#xDEAD" (show #f (with ((radix 16)) #xDEAD)))
+(test "#xDEAD1234" (show #f (with ((radix 16)) #xDEAD) 1234))
+(test "DE.AD"
+    (show #f (with ((radix 16) (precision 2)) (numeric (/ #xDEAD #x100)))))
+(test "D.EAD"
+    (show #f (with ((radix 16) (precision 3)) (numeric (/ #xDEAD #x1000)))))
+(test "0.DEAD"
+    (show #f (with ((radix 16) (precision 4)) (numeric (/ #xDEAD #x10000)))))
+(test "1G"
+    (show #f (with ((radix 17)) (numeric 33))))
+
+(test "3.14159" (show #f 3.14159))
+(test "3.14" (show #f (with ((precision 2)) 3.14159)))
+(test "3.14" (show #f (with ((precision 2)) 3.14)))
+(test "3.00" (show #f (with ((precision 2)) 3.)))
+(test "1.10" (show #f (with ((precision 2)) 1.099)))
+(test "0.00" (show #f (with ((precision 2)) 1e-17)))
+(test "0.0000000010" (show #f (with ((precision 10)) 1e-9)))
+(test "0.0000000000" (show #f (with ((precision 10)) 1e-17)))
+(test "0.000004" (show #f (with ((precision 6)) 0.000004)))
+(test "0.0000040" (show #f (with ((precision 7)) 0.000004)))
+(test "0.00000400" (show #f (with ((precision 8)) 0.000004)))
+
+(test "   3.14159" (show #f (with ((decimal-align 5)) (numeric 3.14159))))
+(test "  31.4159" (show #f (with ((decimal-align 5)) (numeric 31.4159))))
+(test " 314.159" (show #f (with ((decimal-align 5)) (numeric 314.159))))
+(test "3141.59" (show #f (with ((decimal-align 5)) (numeric 3141.59))))
+(test "31415.9" (show #f (with ((decimal-align 5)) (numeric 31415.9))))
+(test "  -3.14159" (show #f (with ((decimal-align 5)) (numeric -3.14159))))
+(test " -31.4159" (show #f (with ((decimal-align 5)) (numeric -31.4159))))
+(test "-314.159" (show #f (with ((decimal-align 5)) (numeric -314.159))))
+(test "-3141.59" (show #f (with ((decimal-align 5)) (numeric -3141.59))))
+(test "-31415.9" (show #f (with ((decimal-align 5)) (numeric -31415.9))))
+
+(cond
+ ((exact? (/ 1 3)) ;; exact rationals
+  (test "333.333333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1000/3))))
+  (test  "33.333333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 100/3))))
+  (test   "3.333333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 10/3))))
+  (test   "0.333333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1/3))))
+  (test   "0.033333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1/30))))
+  (test   "0.003333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1/300))))
+  (test   "0.000333333333333333333333333333"
+      (show #f (with ((precision 30)) (numeric 1/3000))))
+  (test   "0.666666666666666666666666666667"
+      (show #f (with ((precision 30)) (numeric 2/3))))
+  (test   "0.090909090909090909090909090909"
+      (show #f (with ((precision 30)) (numeric 1/11))))
+  (test   "1.428571428571428571428571428571"
+      (show #f (with ((precision 30)) (numeric 10/7))))
+  (test "0.123456789012345678901234567890"
+      (show #f (with ((precision 30))
+                 (numeric (/  123456789012345678901234567890
+                              1000000000000000000000000000000)))))
+  (test  " 333.333333333333333333333333333333"
+      (show #f (with ((precision 30) (decimal-align 5)) (numeric 1000/3))))
+  (test  "  33.333333333333333333333333333333"
+      (show #f (with ((precision 30) (decimal-align 5)) (numeric 100/3))))
+  (test  "   3.333333333333333333333333333333"
+      (show #f (with ((precision 30) (decimal-align 5)) (numeric 10/3))))
+  (test  "   0.333333333333333333333333333333"
+      (show #f (with ((precision 30) (decimal-align 5)) (numeric 1/3))))
+  ))
+
+(test "11.75" (show #f (with ((precision 2)) (/ 47 4))))
+(test "-11.75" (show #f (with ((precision 2)) (/ -47 4))))
+
+(test "(#x11 #x22 #x33)" (show #f (with ((radix 16)) '(#x11 #x22 #x33))))
+
+(test "299792458" (show #f (with ((comma-rule 3)) 299792458)))
+(test "299,792,458" (show #f (with ((comma-rule 3)) (numeric 299792458))))
+(test "-29,97,92,458"
+    (show #f (with ((comma-rule '(3 . 2))) (numeric -299792458))))
+(test "299.792.458"
+    (show #f (with ((comma-rule 3) (comma-sep #\.)) (numeric 299792458))))
+(test "299.792.458,0"
+    (show #f (with ((comma-rule 3) (decimal-sep #\,)) (numeric 299792458.0))))
+
+(test "100,000" (show #f (with ((comma-rule 3)) (numeric 100000))))
+(test "100,000.0"
+    (show #f (with ((comma-rule 3) (precision 1)) (numeric 100000))))
+(test "100,000.00"
+    (show #f (with ((comma-rule 3) (precision 2)) (numeric 100000))))
+
+(cond-expand
+ (complex
+  (test "1+2i" (show #f (string->number "1+2i")))
+  (test "1.00+2.00i"
+      (show #f (with ((precision 2)) (string->number "1+2i"))))
+  (test "3.14+2.00i"
+      (show #f (with ((precision 2)) (string->number "3.14159+2i"))))))
+
+;; padding/trimming
+
+(test "abc  " (show #f (padded 5 "abc")))
+(test "  abc" (show #f (padded/left 5 "abc")))
+(test " abc " (show #f (padded/both 5 "abc")))
+(test "abcde" (show #f (padded 5 "abcde")))
+(test "abcdef" (show #f (padded 5 "abcdef")))
+
+(test "abc" (show #f (trimmed 3 "abcde")))
+(test "abc" (show #f (trimmed 3 "abcd")))
+(test "abc" (show #f (trimmed 3 "abc")))
+(test "ab" (show #f (trimmed 3 "ab")))
+(test "a" (show #f (trimmed 3 "a")))
+(test "cde" (show #f (trimmed/left 3 "abcde")))
+(test "bcd" (show #f (trimmed/both 3 "abcde")))
+(test "bcdef" (show #f (trimmed/both 5 "abcdefgh")))
+(test "abc" (show #f (trimmed/lazy 3 "abcde")))
+(test "abc" (show #f (trimmed/lazy 3 "abc\nde")))
+
+(test "prefix: abc" (show #f "prefix: " (trimmed 3 "abcde")))
+(test "prefix: cde" (show #f "prefix: " (trimmed/left 3 "abcde")))
+(test "prefix: bcd" (show #f "prefix: " (trimmed/both 3 "abcde")))
+(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abcde")))
+(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abc\nde")))
+
+(test "abc :suffix" (show #f (trimmed 3 "abcde") " :suffix"))
+(test "cde :suffix" (show #f (trimmed/left 3 "abcde") " :suffix"))
+(test "bcd :suffix" (show #f (trimmed/both 3 "abcde") " :suffix"))
+(test "abc :suffix" (show #f (trimmed/lazy 3 "abcde") " :suffix"))
+(test "abc :suffix" (show #f (trimmed/lazy 3 "abc\nde") " :suffix"))
+
+(test "abcde"
+    (show #f (with ((ellipsis "...")) (trimmed 5 "abcde"))))
+(test "ab..."
+    (show #f (with ((ellipsis "...")) (trimmed 5 "abcdef"))))
+(test "abc..."
+    (show #f (with ((ellipsis "...")) (trimmed 6 "abcdefg"))))
+(test "abcde"
+    (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcde"))))
+(test "...ef"
+    (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcdef"))))
+(test "...efg"
+    (show #f (with ((ellipsis "...")) (trimmed/left 6 "abcdefg"))))
+(test "abcdefg"
+    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefg"))))
+(test "...d..."
+    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefgh"))))
+(test "...e..."
+    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefghi"))))
+
+(test "abc  " (show #f (fitted 5 "abc")))
+(test "  abc" (show #f (fitted/left 5 "abc")))
+(test " abc " (show #f (fitted/both 5 "abc")))
+(test "abcde" (show #f (fitted 5 "abcde")))
+(test "abcde" (show #f (fitted/left 5 "abcde")))
+(test "abcde" (show #f (fitted/both 5 "abcde")))
+(test "abcde" (show #f (fitted 5 "abcdefgh")))
+(test "defgh" (show #f (fitted/left 5 "abcdefgh")))
+(test "bcdef" (show #f (fitted/both 5 "abcdefgh")))
+
+(test "prefix: abc   :suffix"
+    (show #f "prefix: " (fitted 5 "abc") " :suffix"))
+(test "prefix:   abc :suffix"
+    (show #f "prefix: " (fitted/left 5 "abc") " :suffix"))
+(test "prefix:  abc  :suffix"
+    (show #f "prefix: " (fitted/both 5 "abc") " :suffix"))
+(test "prefix: abcde :suffix"
+    (show #f "prefix: " (fitted 5 "abcde") " :suffix"))
+(test "prefix: abcde :suffix"
+    (show #f "prefix: " (fitted/left 5 "abcde") " :suffix"))
+(test "prefix: abcde :suffix"
+    (show #f "prefix: " (fitted/both 5 "abcde") " :suffix"))
+(test "prefix: abcde :suffix"
+    (show #f "prefix: " (fitted 5 "abcdefgh") " :suffix"))
+(test "prefix: defgh :suffix"
+    (show #f "prefix: " (fitted/left 5 "abcdefgh") " :suffix"))
+(test "prefix: bcdef :suffix"
+    (show #f "prefix: " (fitted/both 5 "abcdefgh") " :suffix"))
+
+;; joining
+
+(test "1 2 3" (show #f (joined each '(1 2 3) " ")))
+
+(test ":abc:123"
+    (show #f (joined/prefix
+              (lambda (x) (trimmed 3 x))
+              '("abcdef" "123456")
+              ":")))
+
+(test "abc\n123\n"
+    (show #f (joined/suffix
+              (lambda (x) (trimmed 3 x))
+              '("abcdef" "123456")
+              nl)))
+
+(test "lions, tigers, and bears"
+    (show #f (joined/last
+              each
+              (lambda (x) (each "and " x))
+              '(lions tigers bears)
+              ", ")))
+
+(test "lions, tigers, or bears"
+    (show #f (joined/dot
+              each
+              (lambda (x) (each "or " x))
+              '(lions tigers . bears)
+              ", ")))
+
+;; shared structures
+
+(test "#0=(1 . #0#)"
+    (show #f (written (let ((ones (list 1))) (set-cdr! ones ones) ones))))
+(test "(0 . #0=(1 . #0#))"
+    (show #f (written (let ((ones (list 1)))
+                        (set-cdr! ones ones)
+                        (cons 0 ones)))))
+(test "(sym . #0=(sym . #0#))"
+    (show #f (written (let ((syms (list 'sym)))
+                        (set-cdr! syms syms)
+                        (cons 'sym syms)))))
+(test "(#0=(1 . #0#) #1=(2 . #1#))"
+    (show #f (written (let ((ones (list 1))
+                            (twos (list 2)))
+                        (set-cdr! ones ones)
+                        (set-cdr! twos twos)
+                        (list ones twos)))))
+(test "(#0=(1 . #0#) #0#)"
+    (show #f (written (let ((ones (list 1)))
+                        (set-cdr! ones ones)
+                        (list ones ones)))))
+(test "((1) (1))"
+    (show #f (written (let ((ones (list 1)))
+                        (list ones ones)))))
+
+(test "(#0=(1) #0#)"
+    (show #f (written-shared (let ((ones (list 1)))
+                               (list ones ones)))))
+
+;; cycles without shared detection
+
+(test "(1 1 1 1 1"
+    (show #f (trimmed/lazy
+             10
+             (written-simply
+              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))
+
+(test "(1 1 1 1 1 "
+    (show #f (trimmed/lazy
+             11
+             (written-simply
+              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))
+
+(test-end)