;; Originally:
;; "genwrite.scm" generic write used by pp.scm
;; copyright (c) 1991, marc feeley

;; Pretty-printer for Racket
;;  Handles structures, cycles, and graphs

;; TO INSTALL this pretty-printer into Racket's read-eval-print loop,
;; require this module and evaluate:
;;      (current-print pretty-print-handler)

(module pretty racket/base
   (require mzlib/private/port)

   (provide pretty-print
            pretty-write
	    pretty-display
	    pretty-print-columns
	    pretty-print-depth
	    pretty-print-handler
	    pretty-print-size-hook
	    pretty-print-print-hook
	    pretty-print-pre-print-hook
	    pretty-print-post-print-hook
	    pretty-print-print-line
	    pretty-print-show-inexactness
	    pretty-print-exact-as-decimal
	    pretty-print-.-symbol-without-bars
            pretty-print-abbreviate-read-macros
            
	    pretty-print-style-table?
	    pretty-print-current-style-table
	    pretty-print-extend-style-table
            pretty-print-remap-stylable
            
            pretty-format
	    pretty-printing
	    pretty-print-newline
	    make-tentative-pretty-print-output-port
	    tentative-pretty-print-port-transfer
	    tentative-pretty-print-port-cancel)

   (define-struct pretty-print-style-table (hash))

   (define pretty-print-extend-style-table
     (lambda (table symbols like-symbols)
       (let ([terr (lambda (kind which)
                     (raise-type-error
                      'pretty-print-extend-style-table
                      kind
                      which
                      table symbols like-symbols))])
         (unless (or (not table) (pretty-print-style-table? table))
           (terr "pretty-print style table or #f" 0))
         (unless (and (list? symbols)
                      (andmap symbol? symbols))
           (terr "list of symbols" 1))
         (unless (and (list? like-symbols)
                      (andmap symbol? like-symbols))
           (terr "list of symbols" 1))
         (unless (= (length symbols) (length like-symbols))
           (raise-mismatch-error
            'pretty-print-extend-style-table
            (format "length of first list (~a) doesn't match the length of the second list (~a): "
                    (length symbols) (length like-symbols))
            like-symbols)))
       (let ([ht (if table (pretty-print-style-table-hash table) (make-hasheq))]
             [new-ht (make-hasheq)])
         (hash-for-each
          ht
          (lambda (key val)
            (hash-set! new-ht key val)))
         (for-each
          (lambda (symbol like-symbol)
            (let ((s (hash-ref ht
                               like-symbol
                               (lambda () #f))))
              (hash-set! new-ht symbol (or s like-symbol))))
          symbols like-symbols)
         (make-pretty-print-style-table new-ht))))

  (define pretty-print-abbreviate-read-macros (make-parameter #t))
  
   (define pretty-print-current-style-table 
     (make-parameter 
      (pretty-print-extend-style-table #f null null)
      (lambda (s)
	(unless (pretty-print-style-table? s)
	  (raise-type-error
	   'pretty-print-current-style-table 
	   "pretty-print style table"
	   s))
	s)))

   (define pretty-print-.-symbol-without-bars
     (make-parameter #f (lambda (x) (and x #t))))

   (define pretty-print-show-inexactness 
     (make-parameter #f
		     (lambda (x) (and x #t))))

   (define pretty-print-exact-as-decimal
     (make-parameter #f
		     (lambda (x) (and x #t))))

   (define pretty-print-columns 
     (make-parameter 79
		     (lambda (x)
		       (unless (or (eq? x 'infinity)
				   (integer? x))
			       (raise-type-error 
				'pretty-print-columns
				"integer or 'infinity"
				x))
		       x)))

   (define pretty-print-depth
     (make-parameter #f
		     (lambda (x)
		       (unless (or (not x) (number? x))
			       (raise-type-error 
				'pretty-print-depth
				"number or #f"
				x))
		       x)))

   (define can-accept-n?
     (lambda (n x)
       (procedure-arity-includes? x n)))
   
   (define pretty-print-size-hook
     (make-parameter (lambda (x display? port) #f)
		     (lambda (x)
		       (unless (can-accept-n? 3 x)
			       (raise-type-error 
				'pretty-print-size-hook
				"procedure of 3 arguments"
				x))
		       x)))

   (define pretty-print-print-hook
     (make-parameter void
		     (lambda (x)
		       (unless (can-accept-n? 3 x)
			       (raise-type-error 
				'pretty-print-print-hook
				"procedure of 3 arguments"
				x))
		       x)))

   (define pretty-print-print-line
     (make-parameter (lambda (line port offset width)
		       (when (and (number? width)
				  (not (eq? 0 line)))
                         (newline port))
		       0)
		     (lambda (x)
		       (unless (can-accept-n? 4 x)
			       (raise-type-error 
				'pretty-print-print-line
				"procedure of 4 arguments"
				x))
		       x)))

   (define pretty-print-pre-print-hook
     (make-parameter void
		     (lambda (x)
		       (unless (can-accept-n? 2 x)
			       (raise-type-error 
				'pretty-print-pre-print-hook
				"procedure of 2 arguments"
				x))
		       x)))

   (define pretty-print-post-print-hook
     (make-parameter void
		     (lambda (x)
		       (unless (can-accept-n? 2 x)
			       (raise-type-error 
				'pretty-print-post-print-hook
				"procedure of 2 arguments"
				x))
		       x)))

   (define pretty-printing
     (make-parameter #f (lambda (x) (and x #t))))
  
  (define pretty-print-remap-stylable
    (make-parameter (λ (x) #f) 
                    (λ (f) 
                      (unless (can-accept-n? 1 f)
                        (raise-type-error
                         'pretty-print-remap-stylable
                         "procedure of 1 argument"
                         f))
                      (λ (x)
                        (let ([res (f x)])
                          (unless (or (not res) (symbol? res))
                            (raise-type-error
                             'pretty-print-remap-stylable
                             "result of parameter function to be a symbol or #f"
                             res))
                          res)))))

   (define make-pretty-print
     (lambda (name display? as-qq?)
       (letrec ([pretty-print
		 (case-lambda 
		  [(obj port qq-depth)
                   (unless (output-port? port)
                     (raise-type-error name "output port" port))
                   (unless (or (equal? qq-depth 0)
                               (equal? qq-depth 1))
                     (raise-type-error name "0 or 1" qq-depth))
		   (let ([width (pretty-print-columns)]
			 [size-hook (pretty-print-size-hook)]
			 [print-hook (pretty-print-print-hook)]
			 [pre-hook (pretty-print-pre-print-hook)]
			 [post-hook (pretty-print-post-print-hook)])
		     (generic-write obj display?
				    width
				    (make-printing-port port 
							pre-hook
							post-hook
							print-hook
							(pretty-print-print-line))
				    (print-graph) (print-struct) (print-hash-table)
				    (and (not display?) (print-vector-length)) (print-box) 
                                    (and (not display?) as-qq? (print-as-expression)) qq-depth
				    (pretty-print-depth)
				    (lambda (o display?)
				      (size-hook o display? port)))
		     (void))]
                  [(obj port) (pretty-print obj port 0)]
		  [(obj) (pretty-print obj (current-output-port))])])
	 pretty-print)))

   (define pretty-print (make-pretty-print 'pretty-print #f #t))
   (define pretty-display (let ([pp (make-pretty-print 'pretty-display #t #f)])
                            (case-lambda
                             [(v) (pp v)]
                             [(v o) (pp v o)])))
   (define pretty-write (let ([pp (make-pretty-print 'pretty-write #f #f)])
                          (case-lambda
                           [(v) (pp v)]
                           [(v o) (pp v o)])))

   (define-struct mark (str def) #:mutable)
   (define-struct hide (val))

   (define (make-tentative-output-port pport width esc)
     (let* ([content null]
	    [special-ok? (port-writes-special? pport)]
            ;; The null device counts for us:
            [/dev/null
             (let-values ([(line col pos) (port-next-location pport)])
               (relocate-output-port 
                (let ([p (open-output-nowhere special-ok?)])
                  (port-count-lines! p)
                  p)
                (or line 1) (or col 0) (or pos 1)))]
            [first-line? #t]
            [check-esc (lambda ()
                         (let-values ([(l c p) (port-next-location /dev/null)])
                           (when (or (c . > . width)
                                     (not first-line?))
                             (esc))))]
            [p (make-output-port
                'tentative
                always-evt
                (lambda (s start end block? break?)
                  (write-bytes s /dev/null start end)
                  (check-esc)
                  (set! content (cons (subbytes s start end) content))
                  (- end start))
                void
                (and special-ok?
                     (lambda (special block break?)
                       (write-special special /dev/null)
                       (check-esc)
                       (set! content (cons (cons 'special special) content))
                       #t))
                #f #f
                (lambda ()
                  (port-next-location /dev/null)))])
       (port-count-lines! /dev/null)
       (port-count-lines! p)
       (register-printing-port p 
                               (make-print-port-info
                                (lambda () (reverse content))
                                (box #t)
                                (lambda (v)
                                  (set! content (cons (cons 'pre v) content)))
                                (lambda (v)
                                  (set! content (cons (cons 'post v) content)))
                                (lambda (v len display?)
                                  (display (make-string len #\.) /dev/null)
                                  (set! content (cons (list* 'hooked v len display?)
                                                      content)))
                                (lambda (use-line? offset width)
                                  (when (and (number? width)
                                             (not first-line?))
                                    (newline p))
                                  (set! first-line? #f)
                                  0)
                                esc))
       p))

   (define (make-tentative-pretty-print-output-port pport width esc)
     (let ([p (make-tentative-output-port pport width esc)])
       (port-write-handler p (port-write-handler pport))
       (port-display-handler p (port-display-handler pport))
       (port-print-handler p (port-print-handler pport))
       p))
   
   (define (make-printing-port port pre-print post-print output-hooked print-line)
     (let-values ([(line col pos) (port-next-location port)])
       (let* ([orig-counts? (and line col pos)]
	      [p (if orig-counts?
		     (relocate-output-port port line col pos #f)
		     (transplant-output-port port #f 1 #f))]
	      [line -1])
	 (port-count-lines! p)
	 (register-printing-port p 
				 (make-print-port-info 
				  (lambda () null)
				  (box #t)
				  (lambda (v)
				    (pre-print v port))
				  (lambda (v)
				    (post-print v port))
				  (lambda (v len display?)
				    (output-hooked v display? p))
				  (lambda (use-line? offset width)
				    (set! line (add1 line))
				    (print-line (and use-line? line) p offset width))
				  void))
	 p)))

   (define printing-ports (make-weak-hasheq))

   (define-struct print-port-info (get-content
				   def-box
				   pre-print
				   post-print
				   output-hooked
				   print-line
				   esc))

   (define (register-printing-port p info)
     (hash-set! printing-ports p (make-ephemeron p info)))

   (define (register-printing-port-like p pport)
     (hash-set! printing-ports p 
                (make-ephemeron p
                                (ephemeron-value (hash-ref printing-ports pport)))))

   (define (get pport selector)
     (let ([e (hash-ref printing-ports pport #f)])
       (selector (if e
		     (ephemeron-value e)
		     (make-print-port-info
		      (lambda () null)
		      (box #t)
		      void void void void void)))))

   (define (printing-port-pre-print pport)
     (get pport print-port-info-pre-print))
   (define (printing-port-post-print pport)
     (get pport print-port-info-post-print))
   (define (printing-port-def-box pport)
     (get pport print-port-info-def-box))
   (define (printing-port-output-hooked pport)
     (get pport print-port-info-output-hooked))
   (define (printing-port-print-line pport)
     (get pport print-port-info-print-line))
   (define (printing-port-esc pport)
     (get pport print-port-info-esc))

   (define orig-display (port-display-handler (open-output-string)))
   (define orig-write (port-write-handler (open-output-string)))
   
   (define (pretty-print-newline pport width)
     (let-values ([(l col p) (port-next-location pport)])
       ((printing-port-print-line pport) #t (or col 0) width)))

   (define (tentative-pretty-print-port-transfer a-pport pport)
     (let ([content ((get a-pport print-port-info-get-content))])
       (for-each (lambda (elem)
		   (if (bytes? elem)
		       (write-bytes elem pport)
		       (case (car elem)
			 [(special) (write-special (cdr elem) pport)]
			 [(pre) ((printing-port-pre-print pport) (cdr elem))]
			 [(post) ((printing-port-post-print pport) (cdr elem))]
			 [(hooked) ((printing-port-output-hooked pport) 
				    (cadr elem) (caddr elem) (cdddr elem))])))
		 content)))
   
   (define (tentative-pretty-print-port-cancel pport)
     (set-box! (get pport print-port-info-def-box) #f))

   (define (add-spaces n port)
     (if (> n 0)
	 (if (> n 7)
	     (begin
	       (write-string "        " port)
	       (add-spaces (- n 8) port))
	     (write-string "        " port 0 n))
         (void)))

   (define (prefab?! obj v)
     (let ([d (prefab-struct-key obj)])
       (and d
            (begin
              (vector-set! v 0 d)
              #t))))

   (define-struct unquoted (val))
   (define struct-ellipses (string->uninterned-symbol "..."))

   (define (generic-write obj display? width pport
			  print-graph? print-struct? print-hash-table? print-vec-length? 
                          print-box? print-as-qq? qq-depth
			  depth size-hook)

     (define pair-open (if (print-pair-curly-braces) "{" "("))
     (define pair-close (if (print-pair-curly-braces) "}" ")"))
     (define mpair-open (if (print-mpair-curly-braces) "{" "("))
     (define mpair-close (if (print-mpair-curly-braces) "}" ")"))
     
     (define table (make-hasheq)) ; Hash table for looking for loops

     (define show-inexactness? (pretty-print-show-inexactness))
     (define exact-as-decimal? (pretty-print-exact-as-decimal))

     (define long-bools? (print-boolean-long-form))
     
     (define vector->repeatless-list
       (if print-vec-length?
	   (lambda (v)
	     (let ([len (vector-length v)])
               (if (zero? len)
                   null
                   (let ([last (vector-ref v (sub1 len))])
                     (let loop ([i (- len 2)])
                       (if (i . < . 0)
                           (list last)
                           (let ([e (vector-ref v i)])
                             (if (eq? e last)
                                 (loop (sub1 i))
                                 (let loop ([i (sub1 i)][r (list e last)])
                                   (if (i . < . 0)
                                       r
                                       (loop (sub1 i) (cons (vector-ref v i) r))))))))))))
           vector->list))

     (define (extract-sub-objects obj pport)
       (let ([p (open-output-nowhere 'null (port-writes-special? pport))]
	     [l null])
	 (let ([record (lambda (o p) (set! l (cons o l)))])
	   (port-write-handler p record)
	   (port-display-handler p record)
	   (port-print-handler p record))
	 (parameterize ([pretty-printing #f])
	   ((custom-write-accessor obj) obj p #f))
	 l))

     (define found-cycle
       (or print-graph?
	   (let loop ([obj obj])
	     (and (or (vector? obj)
		      (pair? obj)
		      (mpair? obj)
		      (and (box? obj)
                           print-box?)
		      (and (custom-write? obj)
			   (not (struct-type? obj)))
		      (and (struct? obj) print-struct?)
		      (and (hash? obj) print-hash-table?))
		  (or (hash-ref table obj #f)
		      (begin
			(hash-set! table obj #t)
			(let ([cycle
			       (cond
				[(vector? obj)
				 (let ([len (vector-length obj)])
				   (let vloop ([i 0])
				     (if (= i len)
					 #f
					 (or (loop (vector-ref obj i))
					     (vloop (add1 i))))))]
				[(pair? obj)
				 (or (loop (car obj))
				     (loop (cdr obj)))]
				[(mpair? obj)
				 (or (loop (mcar obj))
				     (loop (mcdr obj)))]
				[(and (box? obj) print-box?) (loop (unbox obj))]
				[(and (custom-write? obj)
				      (not (struct-type? obj)))
				 (loop (extract-sub-objects obj pport))]
				[(struct? obj)
				 (ormap loop 
					(vector->list (struct->vector obj)))]
				[(hash? obj)
                                 (for/or ([(k v) (in-hash obj)])
                                   (or (loop v) (loop k)))])])
			  (hash-remove! table obj)
			  cycle)))))))

     (define __dummy__
       (when found-cycle
	 (let loop ([obj obj])
	   (if (or (vector? obj)
		   (pair? obj)
		   (mpair? obj)
		   (and (box? obj)
                        print-box?)
		   (and (custom-write? obj)
			(not (struct-type? obj)))
		   (and (struct? obj) print-struct?)
		   (and (hash? obj) print-hash-table?))
	       ;; A little confusing: use #t for not-found
	       (let ([p (hash-ref table obj #t)])
		 (when (not (mark? p))
		   (if p
		       (begin
			 (hash-set! table obj #f)
			 (cond
			  [(vector? obj)
			   (let ([len (vector-length obj)])
			     (let vloop ([i 0])
			       (unless (= i len)
				 (loop (vector-ref obj i))
				 (vloop (add1 i)))))]
			  [(pair? obj)
			   (loop (car obj))
			   (loop (cdr obj))]
			  [(mpair? obj)
			   (loop (mcar obj))
			   (loop (mcdr obj))]
			  [(and (box? obj) print-box?) (loop (unbox obj))]
			  [(and (custom-write? obj)
				(not (struct-type? obj)))
			   (loop (extract-sub-objects obj pport))]
			  [(struct? obj)
			   (for-each loop 
				     (vector->list (struct->vector obj)))]
			  [(hash? obj)
			   (hash-for-each
			    obj
			    (lambda (k v)
			      (loop k)
			      (loop v)))]))
		       (begin
			 (hash-set! table obj 
                                    (make-mark #f (box #f)))))))
               (void)))))

     (define escapes-table
       (let* ([table (make-hasheq)]
              [local-compound (and print-as-qq?
                                   (make-hasheq))]
              [is-compound! (lambda (obj)
                              (hash-set! local-compound obj #t))]
              [escapes! (lambda (obj)
                          (hash-set! table obj #t)
                          #t)]
              [orf (lambda (a b) (or a b))])
         (when print-as-qq?
           (let loop ([obj obj])
             (cond
              [(hash-ref table obj #f)
               ;; already decided that it escapes
               #t]
              [(and local-compound 
                    (hash-ref local-compound obj #f))
               ;; either still deciding (so assume #f) or
               ;; already decided that no escape is needed
               #f]
              [else
               (cond
                [(vector? obj)
                 (is-compound! obj)
                 (let ([len (vector-length obj)])
                   (let vloop ([esc? #f][i 0])
                     (if (= i len)
                         (and esc? 
                              (escapes! obj))
                         (vloop (or (loop (vector-ref obj i)) esc?) 
                                (add1 i)))))]
                [(pair? obj)
                 (is-compound! obj)
                 (and (orf (loop (car obj))
                           (loop (cdr obj)))
                      (escapes! obj))]
                [(mpair? obj)
                 (is-compound! obj)
                 (loop (mcar obj))
                 (loop (mcdr obj))
                 ;; always unquoted:
                 #t]
                [(and (box? obj) print-box?) 
                 (is-compound! obj)
                 (and (loop (unbox obj))
                      (escapes! obj))]
                [(and (custom-write? obj)
                      (not (struct-type? obj)))
                 (is-compound! obj)
                 (let ([kind (if (custom-print-quotable? obj)
                                 (custom-print-quotable-accessor obj)
                                 'self)])
                   (and (or (and (loop (extract-sub-objects obj pport))
                                 (not (memq kind '(self always))))
                            (memq kind '(never)))
                        (escapes! obj)))]
                [(struct? obj)
                 (is-compound! obj)
                 (and (or (loop (struct->vector obj))
                          (not (prefab-struct-key obj)))
                      (escapes! obj))]
                [(hash? obj)
                 (is-compound! obj)
                 (and (for/fold ([esc? #f]) ([(k v) (in-hash obj)])
                        (or (orf (loop v) 
                                 (loop k))
                            esc?))
                      (escapes! obj))]
                [else #f])])))
         table))

     (define cycle-counter 0)

     (define found (if found-cycle
		       table 
		       #f))

     (define dsub1 (lambda (d)
		     (if d
			 (sub1 d)
			 #f)))

     (define (pre-print pport obj)
       ((printing-port-pre-print pport) obj))
     (define (post-print pport obj)
       ((printing-port-post-print pport)
	obj))
     (define (output-hooked pport obj len display?)
       ((printing-port-output-hooked pport)
	obj len display?))

     (define expr-found
       (lambda (pport ref)
	 (let ([n cycle-counter])
	   (set! cycle-counter (add1 cycle-counter))
	   (set-mark-str! ref 
			  (string-append "#"
					 (number->string n)
					 "#"))
	   (set-mark-def! ref (printing-port-def-box pport))
	   (display (string-append "#"
				   (number->string n)
				   "=")
		    pport))))
     
     (define check-expr-found
       (lambda (obj pport check? c-k d-k n-k)
	 (let ([ref (and check? 
			 found
			 (hash-ref found obj #f))])
	   (if (and ref (unbox (mark-def ref)))
	       (if c-k
		   (c-k (mark-str ref))
		   (display (mark-str ref) pport))
	       (if (and ref d-k)
		   (d-k)
		   (begin
		     (when ref
		       (expr-found pport ref))
		     (n-k)))))))

     (define (write-custom recur obj pport depth display? width qd multi-line?)
       (let-values ([(l c p) (port-next-location pport)])
	 (let ([p (relocate-output-port pport l c p)])
	   (port-count-lines! p)
	   (let ([writer (lambda (v port)
			   (recur port v (dsub1 depth) #f #f))]
		 [displayer (lambda (v port)
			      (recur port v (dsub1 depth) #t #f))]
                 [printer (case-lambda 
                           [(v port) (recur port v (dsub1 depth) #f qd)]
                           [(v port qd) (recur port v (dsub1 depth) #f qd)])])
	     (port-write-handler p writer)
	     (port-display-handler p displayer)
	     (port-print-handler p printer))
	   (register-printing-port-like p pport)
	   (parameterize ([pretty-printing multi-line?]
			  [pretty-print-columns (or width 'infinity)])
	     ((custom-write-accessor obj) obj p (or qd (not display?)))))))

     ;; ------------------------------------------------------------
     
     (define (convert-pair obj)
       (cond
        [(list? obj) (cons (make-unquoted 'list) 
                           ;; reconstruct first pair in case it
                           ;; starts a cycle:
                           (cons (car obj) (cdr obj)))]
        [(and (pair? (cdr obj)) 
              (not (and found
                        (hash-ref found (cdr obj) #f))))
         (cons (make-unquoted 'list*)
               (cons
                (car obj)
                (let loop ([obj (cdr obj)])
                  (cond
                   [(and found (hash-ref found obj #f)) (list obj)]
                   [(pair? obj) (cons (car obj) (loop (cdr obj)))]
                   [else (list obj)]))))]
        [else (list (make-unquoted 'cons) (car obj) (cdr obj))]))

     (define (convert-hash obj expr?)
       (let ([l (hash-map obj (lambda (k v)
                                (if expr?
                                    (list k v)
                                    (cons k (make-hide v)))))])
         (if expr?
             (cons (make-unquoted
                    (if (hash-eq? obj)
                        'hasheq
                        (if (hash-eqv? obj)
                            'hasheqv
                            'hash)))
                   (apply append l))
             l)))
     
     ;; ------------------------------------------------------------
     ;; wr: write on a single line
     (define (wr* pport obj depth display? qd)

       (define (out str)
	 (write-string str pport))
       
       (define (wr obj depth qd)
	 (wr* pport obj depth display? qd))

       (define (wr-expr expr depth pair? car cdr open close qd)
	 (if (and (read-macro? expr pair? car cdr qd)
                  (equal? open "("))
	     (begin
	       (out (read-macro-prefix expr car))
	       (wr (read-macro-body expr car cdr) depth qd))
	     (wr-lst expr #t depth pair? car cdr open close qd)))

       (define (wr-lst l check? depth pair? car cdr open close qd)
	 (if (pair? l)
	     (if (and depth (zero? depth))
                 (begin
                   (out open)
                   (out "...")
                   (out close))
                 (begin
                   (out open)
                   (wr (car l) (dsub1 depth) qd)
                   (let loop ([l (cdr l)])
                     (check-expr-found
                      l pport (and check? (pair? l))
                      (lambda (s) (out " . ") (out s) (out close))
                      (lambda ()
                        (out " . ")
                        (check-expr-found ;; will find it!
                         l pport #t
                         #f #f
                         (lambda ()
                           (wr-lst l check? (dsub1 depth) pair? car cdr open close qd)))
                        (out close))
                      (lambda ()
                        (cond 
                         [(pair? l) 
                          (if (and (eq? (do-remap (car l)) 'unquote)
                                   (not (equal? qd 1))
                                   (pair? (cdr l))
                                   (null? (cdr (cdr l))))
                              (begin
                                (out " . ,")
                                (wr (car (cdr l)) (dsub1 depth) qd)
                                (out close))
                              (begin
                                (out " ")
                                (wr (car l) (dsub1 depth) qd)
                                (loop (cdr l))))]
                         [(null? l) (out close)]
                         [else
                          (out " . ")
                          (wr l (dsub1 depth) qd)
                          (out close)]))))))
             (begin
               (out open)
               (out close))))

       (unless (hide? obj)
         (pre-print pport obj))
       (if (and depth 
                (negative? depth)
                (not (hide? obj)))
	   (out "...")
	   
	   (cond 
	    [(size-hook obj display?)
	     => (lambda (len)
		  (output-hooked pport obj len display?))]
	    
	    [(pair? obj)
             (check-expr-found
              obj pport #t
              #f #f
              (lambda ()
                (let* ([qd (to-quoted out qd obj)]
                       [pair (if (and qd (zero? qd))
                                 (convert-pair obj)
                                 obj)])
                  (wr-expr pair depth pair? car cdr pair-open pair-close qd))))]
	    [(mpair? obj) 
             (check-expr-found
              obj pport #t
              #f #f
              (lambda ()
                (if (and qd (zero? qd))
                    (wr-expr (list (make-unquoted 'mcons) (mcar obj) (mcdr obj))
                             depth pair? car cdr pair-open pair-close qd)
                    (wr-expr obj depth mpair? mcar mcdr mpair-open mpair-close qd))))]
	    [(null? obj)
             (let ([qd (to-quoted out qd obj)])
               (wr-lst obj #f depth pair? car cdr "(" ")" qd))]
	    [(vector? obj)   
             (check-expr-found
              obj pport #t
              #f #f
              (lambda ()
                (let ([qd (to-quoted out qd obj)]
                      [vecl (vector->repeatless-list obj)])
                  (if (and qd (zero? qd))
                      (wr-lst (cons (make-unquoted 'vector) vecl)
                              #f depth pair? car cdr "(" ")" qd)
                      (begin
                        (out "#")
                        (when print-vec-length?
                          (out (number->string (vector-length obj))))
                        (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))]
	    [(and (box? obj)
                  print-box?)
             (check-expr-found
              obj pport #t
              #f #f
              (lambda ()
                (let ([qd (to-quoted out qd obj)])
                  (if (and qd (zero? qd))
                      (wr-lst (list (make-unquoted 'box) (unbox obj))
                              #f depth pair? car cdr "(" ")" qd)
                      (begin
                        (out "#&") 
                        (wr (unbox obj) (dsub1 depth) qd))))))]
	    [(and (custom-write? obj) 
		  (not (struct-type? obj)))
	     (check-expr-found
	      obj pport #t
	      #f #f
	      (lambda ()
		(parameterize ([pretty-print-columns 'infinity])
                  (let ([qd (let ([kind (if (custom-print-quotable? obj)
                                            (custom-print-quotable-accessor obj)
                                            'self)])
                              (if (memq kind '(self never))
                                  qd
                                  (to-quoted out qd obj)))])
                    (write-custom wr* obj pport depth display? width qd #f)))))]
	    [(struct? obj)
	     (if (and print-struct?
		      (not (and depth
				(zero? depth))))
		 (check-expr-found
		  obj pport #t
		  #f #f
		  (lambda ()
                    (let* ([v (struct->vector obj struct-ellipses)]
                           [pf? (prefab?! obj v)])
                      (let ([qd (if pf?
                                    (to-quoted out qd obj)
                                    qd)])
                        (when (or (not qd) (positive? qd))
                          (out "#")
                          (when pf? (out "s")))
                        (wr-lst (let ([l (vector->list v)])
                                  (if (and qd (zero? qd))
                                      (cons (make-unquoted (object-name obj))
                                            (cdr l))
                                      l))
                                #f (dsub1 depth) pair? car cdr "(" ")" 
                                qd)))))
                 (parameterize ([print-struct #f])
		   ((if display? orig-display orig-write) obj pport)))]
	    [(hash? obj)  
	     (if (and print-hash-table?
		      (not (and depth
				(zero? depth))))
		 (check-expr-found
		  obj pport #t
		  #f #f
		  (lambda ()
                    (let* ([qd (to-quoted out qd obj)]
                           [expr? (and qd (zero? qd))])
                      (unless expr?
                        (out (if (hash-eq? obj)
                                 "#hasheq"
                                 (if (hash-eqv? obj)
                                     "#hasheqv"
                                     "#hash"))))
                      (wr-lst (convert-hash obj expr?)
                              #f depth
                              pair? car cdr "(" ")" qd))))
		 (parameterize ([print-hash-table #f])
		   ((if display? orig-display orig-write) obj pport)))]
            [(hide? obj)
             (wr* pport (hide-val obj) depth display? qd)]
	    [(boolean? obj)
	     (out (if long-bools?
                      (if obj "#true" "#false")
                      (if obj "#t" "#f")))]
	    [(number? obj)
	     (when (and show-inexactness?
			(inexact? obj))
	       (out "#i"))
	     (out ((if exact-as-decimal?
		       number->decimal-string
		       number->string)
		   obj))]
	    [(and (pretty-print-.-symbol-without-bars)
		  (eq? obj '|.|))
	     (out ".")]
            [(and qd (or (symbol? obj)
                         (keyword? obj)))
             (unless (eq? obj struct-ellipses)
               (to-quoted out qd obj))
             (orig-write obj pport)]
            [(unquoted? obj)
             (orig-write (unquoted-val obj) pport)]
	    [else
	     ((if display? orig-display orig-write) obj pport)]))
       (unless (hide? obj)
         (post-print pport obj)))

     ;; ------------------------------------------------------------
     ;; pp: write on (potentially) multiple lines
     (define (pp* pport obj depth display? qd)

       (define (pp obj depth)
	 (pp* pport obj depth display? qd))

       (define (out str)
	 (write-string str pport))
       
       (define (spaces n)
	 (add-spaces n pport))

       (define (ccol)
	 (let-values ([(l col p) (port-next-location pport)])
	   col))

       (define (indent to)
	 (let ([col (ccol)])
	   (if (< to col)
	       (begin
		 (let ([col ((printing-port-print-line pport) #t col width)])
		   (spaces (- to col))))
	       (spaces (max 0 (- to col))))))

       (define (pr obj extra pp-pair depth qd)
	 ;; may have to split on multiple lines
	 (let* ([obj (if (hide? obj) (hide-val obj) obj)]
                [can-multi (and width
                                (not (size-hook obj display?))
				(or (pair? obj)
                                    (mpair? obj)
                                    (vector? obj) 
				    (and (box? obj) print-box?)
				    (and (custom-write? obj)
					 (not (struct-type? obj)))
				    (and (struct? obj) print-struct?)
				    (and (hash? obj) print-hash-table?)))]
		[graph-ref (if can-multi
			       (and found (hash-ref found obj #f))
			       #f)]
		[old-counter cycle-counter])
	   (if (and can-multi
		    (or (not graph-ref) 
			(not (unbox (mark-def graph-ref)))))
	       ;; It might be possible to split obj across lines.
	       ;; Try writing the obj, but accumulate the info that goes out
	       ;;  into a-pport
	       (let ([a-pport
		      (let/ec esc
			(letrec ([a-pport (make-tentative-output-port
					   pport 
					   (- width extra)
					   (lambda () (esc a-pport)))])
			  ;; Here's the attempt to write on one line:
			  (wr* a-pport obj depth display? qd)
			  a-pport))])
		 (let-values ([(l c p) (port-next-location a-pport)])
		   (if (<= c (- width extra))
		       ;; All can be printed on one line, so just dump the
		       ;;  accumulated text
		       (tentative-pretty-print-port-transfer a-pport pport)
		       ;; Doesn't fit on one line, so start over
		       (begin
			 (tentative-pretty-print-port-cancel a-pport)
			 (set! cycle-counter old-counter)
			 (when graph-ref
			   (expr-found pport graph-ref))
			 (pre-print pport obj)
			 (cond
			  [(pair? obj) 
                           (let* ([qd (to-quoted out qd obj)]
                                  [pair (if (and qd (zero? qd))
                                            (convert-pair obj)
                                            obj)])
                             (pp-pair pair extra depth 
                                      pair? car cdr pair-open pair-close
                                      qd))]
                          [(mpair? obj)
                           (if (and qd (zero? qd))
                               (pp-pair (list (make-unquoted 'mcons) (mcar obj) (mcdr obj))
                                        extra depth 
                                        pair? car cdr pair-open pair-close
                                        qd)
                               (pp-pair obj extra depth 
                                        mpair? mcar mcdr mpair-open mpair-close
                                        qd))]
			  [(vector? obj)
                           (let ([qd (to-quoted out qd obj)]
                                 [vecl (vector->repeatless-list obj)])
                             (if (and qd (zero? qd))
                                 (pp-pair (cons (make-unquoted 'vector) vecl)
                                          extra depth 
                                          pair? car cdr pair-open pair-close
                                          qd)
                                 (begin
                                   (out "#")
                                   (when print-vec-length?
                                     (out (number->string (vector-length obj))))
                                   (pp-list vecl extra pp-expr #f depth
                                            pair? car cdr pair-open pair-close
                                            qd))))]
			  [(and (custom-write? obj)
				(not (struct-type? obj)))
                           (let ([qd (let ([kind (if (custom-print-quotable? obj)
                                            (custom-print-quotable-accessor obj)
                                            'self)])
                                       (if (memq kind '(self never))
                                           qd
                                           (to-quoted out qd obj)))])
                             (write-custom pp* obj pport depth display? width qd #t))]
			  [(struct? obj) ; print-struct is on if we got here
                           (let* ([v (struct->vector obj struct-ellipses)]
                                  [pf? (prefab?! obj v)])
                             (let ([qd (if pf?
                                           (to-quoted out qd obj)
                                           qd)])
                               (when (or (not qd) (positive? qd))
                                 (out "#")
                                 (when pf? (out "s")))
                               (pp-list (let ([l (vector->list v)])
                                          (if (and qd (zero? qd))
                                              (cons (make-unquoted (object-name obj))
                                                    (cdr l))
                                              l))
                                        extra pp-expr #f depth
                                        pair? car cdr pair-open pair-close
                                        qd)))]
			  [(hash? obj)
                           (let* ([qd (to-quoted out qd obj)]
                                  [expr? (and qd (zero? qd))])
                             (unless expr?
                               (out (if (hash-eq? obj)
                                        "#hasheq"
                                        (if (hash-eqv? obj)
                                            "#hasheqv"
                                            "#hash"))))
                             (pp-list (convert-hash obj expr?) extra pp-expr #f depth
                                      pair? car cdr pair-open pair-close
                                      qd))]
			  [(and (box? obj) print-box?)
                           (let ([qd (to-quoted out qd obj)])
                             (if (and qd (zero? qd))
                                 (pp-pair (list (make-unquoted 'box) (unbox obj))
                                          extra depth 
                                          pair? car cdr pair-open pair-close
                                          qd)
                                 (begin
                                   (out "#&") 
                                   (pr (unbox obj) extra pp-pair depth qd))))])
			 (post-print pport obj)))))
	       ;; Not possible to split obj across lines; so just write directly
	       (wr* pport obj depth display? qd))))

       (define (pp-expr expr extra depth
                        apair? acar acdr open close
                        qd)
	 (if (and (read-macro? expr apair? acar acdr qd)
                  (equal? open "(")
                  (not (and found (hash-ref found (acdr expr) #f))))
	     (begin
	       (out (read-macro-prefix expr acar))
	       (pr (read-macro-body expr acar acdr)
		   extra
		   pp-expr
		   depth
                   qd))
	     (let ((head (acar expr)))
	       (if (or (and (symbol? head)
                            (not (size-hook head display?)))
                       ((pretty-print-remap-stylable) head))
		   (let ((proc (style head expr apair? acar acdr)))
		     (if proc
                         (let* ([qd (to-quoted out qd expr)]
                                [pair (if (and qd (zero? qd))
                                          (cons (make-unquoted 'list) obj)
                                          obj)])
                           (proc expr extra depth
                                 apair? acar acdr open close
                                 qd))
			 (if (and #f
                                  ;; Why this special case? Currently disabled.
                                  (> (string-length 
                                      (symbol->string
                                       (if (symbol? head)
                                           head
                                           ((pretty-print-remap-stylable) head))))
                                     max-call-head-width))
                             (pp-general expr extra #f #f #f pp-expr depth
                                         apair? acar acdr open close
                                         qd)
			     (pp-list expr extra pp-expr #t depth
                                      apair? acar acdr open close
                                      qd))))
		   (pp-list expr extra pp-expr #t depth
                            apair? acar acdr open close
                            qd)))))

       (define (wr obj depth qd)
	 (wr* pport obj depth display? qd))

       ;; (head item1
       ;;       item2
       ;;       item3)
       (define (pp-call expr extra pp-item depth
                        apair? acar acdr open close
                        qd)
         (out open)
         (wr (acar expr) (dsub1 depth) qd)
         (let ([col (+ (ccol) 1)])
           (pp-down close (acdr expr) col col extra pp-item #t #t depth
                    apair? acar acdr open close
                    qd)))

       ;; (head item1 item2
       ;;   item3
       ;;   item4)
       (define (pp-two-up expr extra pp-item depth
                          apair? acar acdr open close
                          qd)
	 (out open)
	 (let ([col (ccol)])
	   (wr (acar expr) (dsub1 depth) qd)
	   (out " ")
	   (wr (acar (acdr expr)) (dsub1 depth) qd)
	   (pp-down close (acdr (acdr expr)) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth
                    apair? acar acdr open close 
                    qd)))

       ;; (head item1
       ;;   item2
       ;;   item3)
       (define (pp-one-up expr extra pp-item depth
                          apair? acar acdr open close
                          qd)
	 (out open)
	 (let ([col (ccol)])
	   (wr (acar expr) (dsub1 depth) qd)
	   (pp-down close (acdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth
                    apair? acar acdr open close 
                    qd)))

       ;; (item1
       ;;  item2
       ;;  item3)
       (define (pp-list l extra pp-item check? depth
                        apair? acar acdr open close
                        qd)
	 (out open)
	 (let ([col (ccol)])
	   (pp-down close l col col extra pp-item #f check? depth
                    apair? acar acdr open close
                    qd)))

       (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth
                        apair? acar acdr open close 
                        qd)
	 (let loop ([l l] [icol col1] [check? check-first?])
	   (check-expr-found
	    l pport (and check? (apair? l))
	    (lambda (s) 
	      (indent col2)
	      (out ".")
	      (indent col2)
	      (out s)
	      (out closer))
	    (lambda ()
	      (indent col2)
	      (out ".")
	      (indent col2)
	      (pr l extra pp-item depth qd)
	      (out closer))
	    (lambda ()
	      (cond 
	       [(apair? l)
		(let ([rest (acdr l)])
		  (let ([extra (if (null? rest) (+ extra 1) 0)])
		    (indent icol)
		    (pr (acar l) extra pp-item (dsub1 depth) qd)
		    (loop rest col2 check-rest?)))]
	       [(null? l)
		(out closer)]
	       [else
		(indent col2)
		(out ".")
		(indent col2)
		(pr l (+ extra 1) pp-item (dsub1 depth) qd)
		(out closer)])))))

       (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth
                           apair? acar acdr open close
                           qd)

	 (define (tail1 rest col1 col3)
	   (if (and pp-1 (apair? rest))
	       (let* ((val1 (acar rest))
		      (rest (acdr rest))
		      (extra (if (null? rest) (+ extra 1) 0)))
		 (indent col3)
		 (pr val1 extra pp-1 depth qd)
		 (tail2 rest col1 col3))
	       (tail2 rest col1 col3)))

	 (define (tail2 rest col1 col3)
	   (if (and pp-2 (apair? rest))
	       (let* ((val1 (acar rest))
		      (rest (acdr rest))
		      (extra (if (null? rest) (+ extra 1) 0)))
		 (indent col3)
		 (pr val1 extra pp-2 depth qd)
		 (tail3 rest col1))
	       (tail3 rest col1)))

	 (define (tail3 rest col1)
	   (pp-down close rest col1 col1 extra pp-3 #f #t depth
                    apair? acar acdr open close
                    qd))

	 (let* ([head (acar expr)]
		[rest (acdr expr)]
		[col (ccol)])
	   (out open)
	   (wr head (dsub1 depth) qd)
	   (if (and named? (apair? rest))
	       (let* ((name (acar rest))
		      (rest (acdr rest)))
		 (out " ")
		 (wr name (dsub1 depth) qd)
		 (tail1 rest (+ col indent-general) (+ (ccol) 1)))
	       (tail1 rest (+ col indent-general) (+ (ccol) 1)))))

       (define (pp-expr-list l extra depth
                             apair? acar acdr open close
                             qd)
	 (pp-list l extra pp-expr #t depth
                  apair? acar acdr open close
                  qd))

       (define (pp-lambda expr extra depth
                          apair? acar acdr open close
                          qd)
	 (pp-general expr extra #f pp-expr-list #f pp-expr depth
                     apair? acar acdr open close
                     qd))

       (define (pp-if expr extra depth
                      apair? acar acdr open close
                      qd)
	 (pp-general expr extra #f pp-expr #f pp-expr depth
                     apair? acar acdr open close
                     qd))

       (define (pp-cond expr extra depth
                        apair? acar acdr open close
                        qd)
	 (pp-list expr extra pp-expr-list #t depth
                  apair? acar acdr open close
                  qd))

       (define (pp-syntax-case expr extra depth
                               apair? acar acdr open close
                               qd)
	 (pp-two-up expr extra pp-expr-list depth
                    apair? acar acdr open close
                    qd))

       (define (pp-module expr extra depth
                          apair? acar acdr open close
                          qd)
         (pp-two-up expr extra pp-expr depth
                    apair? acar acdr open close
                    qd))

       (define (pp-make-object expr extra depth
                               apair? acar acdr open close
                               qd)
	 (pp-one-up expr extra pp-expr-list depth
                    apair? acar acdr open close
                    qd))

       (define (pp-case expr extra depth
                        apair? acar acdr open close
                        qd)
	 (pp-general expr extra #f pp-expr #f pp-expr-list depth
                     apair? acar acdr open close
                     qd))

       (define (pp-and expr extra depth
                       apair? acar acdr open close
                       qd)
	 (pp-call expr extra pp-expr depth
                  apair? acar acdr open close
                  qd))

       (define (pp-let expr extra depth
                       apair? acar acdr open close
                       qd)
	 (let* ((rest (acdr expr))
		(named? (and (apair? rest) (symbol? (do-remap (acar rest))))))
	   (pp-general expr extra named? pp-expr-list #f pp-expr depth
                       apair? acar acdr open close
                       qd)))

       (define (pp-begin expr extra depth
                         apair? acar acdr open close
                         qd)
	 (pp-general expr extra #f #f #f pp-expr depth
                     apair? acar acdr open close
                     qd))

       (define (pp-do expr extra depth
                      apair? acar acdr open close
                      qd)
	 (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth
                     apair? acar acdr open close
                     qd))

       ;; define formatting style (change these to suit your style)

       (define indent-general 2)

       (define max-call-head-width 5)

       (define (no-sharing? expr count apair? acdr)
         (if (apair? expr)
             (if (and found 
                      (hash-ref found (acdr expr) #f))
                 #f
                 (or (zero? count)
                     (no-sharing? (acdr expr) (sub1 count) apair? acdr)))
             #f))

       (define (style head expr apair? acar acdr)
         (case (look-in-style-table head)
	   ((lambda λ define define-macro define-syntax
		    syntax-rules
		    shared
		    unless when)
            (and (no-sharing? expr 1 apair? acdr)
                 pp-lambda))
	   ((if set! set!-values)
            (and (no-sharing? expr 1 apair? acdr)
                 pp-if))
	   ((cond case-lambda)
            (and (no-sharing? expr 0 apair? acdr)
                 pp-cond))
	   ((case class) 
            (and (no-sharing? expr 1 apair? acdr)
                 pp-case))
	   ((and or import export 
		 require require-for-syntax require-for-template 
		 provide link
		 public private override rename inherit field init)
            (and (no-sharing? expr 0 apair? acdr)
                 pp-and))
	   ((let letrec let*
	      let-values letrec-values let*-values
	      let-syntax letrec-syntax
	      let-syntaxes letrec-syntaxes)
            (and (no-sharing? expr
                              (if (and (apair? (acdr expr))
                                       (symbol? (acar (acdr expr))))
                                  2
                                  1)
                              apair?
                              acdr)
                 pp-let))
	   ((begin begin0)
            (and (no-sharing? expr 0 apair? acdr)
                 pp-begin))
	   ((do letrec-syntaxes+values)
            (and (no-sharing? expr 2 apair? acdr)
                 pp-do))
           ((module)
            (and (no-sharing? expr 2 apair? acdr)
                 pp-module))
	   ((send syntax-case instantiate)
            (and (no-sharing? expr 2 apair? acdr)
                 pp-syntax-case))
	   ((make-object)
            (and (no-sharing? expr 1 apair? acdr)
                 pp-make-object))

	   (else #f)))

       (pr obj 0 pp-expr depth qd))

     (define (to-quoted out qd obj)
       (and qd
            (if (zero? qd)
                (if (hash-ref escapes-table obj #f)
                    qd
                    (begin
                      (out "'")
                      (add1 qd)))
                qd)))

     ;; ------------------------------------------------------------
     ;; This is where generic-write's body expressions start

     ((printing-port-print-line pport) #t 0 width)
     (let ([qd (if print-as-qq? qq-depth #f)])
       (let-values ([(l col p) (port-next-location pport)])
         (if (and width (not (eq? width 'infinity)))
             (pp* pport obj depth display? qd)
             (wr* pport obj depth display? qd))))
     (let-values ([(l col p) (port-next-location pport)])
       ((printing-port-print-line pport) #f col width)))
  
  (define (look-in-style-table raw-head)
    (let ([head (do-remap raw-head)])
      (or (hash-ref (pretty-print-style-table-hash
                     (pretty-print-current-style-table))
                    head
                    #f)
          head)))
  
  (define (do-remap raw-head)
    (cond
      [((pretty-print-remap-stylable) raw-head)
       => 
       values]
      [else raw-head]))
   
  (define (read-macro? l pair? car cdr qd)
     (define (length1? l) (and (pair? l) (null? (cdr l))))
     (and (pretty-print-abbreviate-read-macros)
          (let ((head (do-remap (car l))) (tail (cdr l)))
            (case head
              ((quote quasiquote syntax
                quasisyntax unsyntax unsyntax-splicing
                unquote unquote-splicing)
               (length1? tail))
              (else #f)))))
            
   (define (read-macro-body l car cdr)
     (car (cdr l)))
  
   (define (read-macro-prefix l car)
     (let ((head (do-remap (car l))))
       (case head
	 ((quote)             "'")
	 ((quasiquote)        "`")
	 ((unquote)           ",")
	 ((unquote-splicing)  ",@")
	 ((syntax)            "#'")
         ((quasisyntax)       "#`")
	 ((unsyntax)          "#,")
	 ((unsyntax-splicing) "#,@"))))
  
   (define pretty-print-handler
     (lambda (v)
       (unless (void? v)
	       (pretty-print v))))

   (define (number->decimal-string x)
     (cond
      [(or (inexact? x)
	   (integer? x))
       (number->string x)]
      [(not (real? x))
       (let ([r (real-part x)]
	     [i (imag-part x)])
	 (format "~a~a~ai"
		 (number->decimal-string r)
		 (if (negative? i)
		     ""
		     "+")
		 (number->decimal-string i)))]
      [else
       (let ([n (numerator x)]
	     [d (denominator x)])
	 ;; Count powers of 2 in denomintor
	 (let loop ([v d][2-power 0])
	   (if (and (positive? v)
		    (even? v))
	       (loop (arithmetic-shift v -1) (add1 2-power))
	       ;; Count powers of 5 in denominator
	       (let loop ([v v][5-power 0])
		 (if (zero? (remainder v 5))
		     (loop (quotient v 5) (add1 5-power))
		     ;; No more 2s or 5s. Anything left?
		     (if (= v 1)
			 ;; Denominator = (* (expt 2 2-power) (expt 5 5-power)).
			 ;; Print number as decimal.
			 (let* ([10-power (max 2-power 5-power)]
				[scale (* (expt 2 (- 10-power 2-power))
					  (expt 5 (- 10-power 5-power)))]
				[s (number->string (* (abs n) scale))]
				[orig-len (string-length s)]
				[len (max (add1 10-power) orig-len)]
				[padded-s (if (< orig-len len)
					      (string-append
					       (make-string (- len orig-len) #\0)
					       s)
					      s)])
			   (format "~a~a.~a"
				   (if (negative? n) "-" "")
				   (substring padded-s 0 (- len 10-power))
				   (substring padded-s (- len 10-power) len)))
			 ;; d has factor(s) other than 2 and 5.
			 ;; Print as a fraction.
			 (number->string x)))))))]))
  
  (define pretty-format
    (case-lambda
      [(t) (pretty-format t (pretty-print-columns))]
      [(t w)
       (parameterize ([pretty-print-columns w])
         (let ([op (open-output-string)])
           (pretty-print t op)
           (let ([s (get-output-string op)])
             (if (eq? w 'infinity)
                 s
                 (substring s 0 (- (string-length s) 1))))))]))

  
  )