Robert Fisher

#!r6rs
(import (rnrs))

(define text '(("#!r6rs"
                "(import (rnrs))"
                ""
                "(define text '(")
               #f
               ("))"
                ""
                "(define (add-between lyst between)"
                "  (reverse (fold-left (lambda (a b)"
                "                        (cons* b between a))"
                "                      (list (car lyst))"
                "                      (cdr lyst))))"
                ""
                "(define (print-list PRINT-PROC LIST BETWEEN-PROC)"
                "  (for-each (lambda (thunk)"
                "              (thunk))"
                "            (add-between (map (lambda (subitem)"
                "                                (lambda ()"
                "                                  (PRINT-PROC subitem)))"
                "                              LIST)"
                "                         BETWEEN-PROC)))"
                ""
                "(define (for-each-if TRUE-PROC FALSE-PROC LIST)"
                "  (for-each (lambda (item)"
                "              (if item"
                "                  (TRUE-PROC item)"
                "                  (FALSE-PROC)))"
                "            LIST))"
                ""
                "(define (indent n)"
                "  (newline)"
                "  (display (make-string n #\\space)))"
                ""
                "(for-each-if (lambda (item)"
                "               (print-list display item newline))"
                "             (lambda ()"
                "               (for-each-if (lambda (item)"
                "                              (display \"(\")"
                "                              (print-list write"
                "                                          item"
                "                                          (lambda ()"
                "                                            (indent 16)))"
                "                              (display \")\"))"
                "                            (lambda ()"
                "                              (indent 15)"
                "                              (write #f)"
                "                              (indent 15))"
                "                            text))"
                "             text)"
                "")))

(define (add-between lyst between)
  (reverse (fold-left (lambda (a b)
                        (cons* b between a))
                      (list (car lyst))
                      (cdr lyst))))

(define (print-list PRINT-PROC LIST BETWEEN-PROC)
  (for-each (lambda (thunk)
              (thunk))
            (add-between (map (lambda (subitem)
                                (lambda ()
                                  (PRINT-PROC subitem)))
                              LIST)
                         BETWEEN-PROC)))

(define (for-each-if TRUE-PROC FALSE-PROC LIST)
  (for-each (lambda (item)
              (if item
                  (TRUE-PROC item)
                  (FALSE-PROC)))
            LIST))

(define (indent n)
  (newline)
  (display (make-string n #\space)))

(for-each-if (lambda (item)
               (print-list display item newline))
             (lambda ()
               (for-each-if (lambda (item)
                              (display "(")
                              (print-list write
                                          item
                                          (lambda ()
                                            (indent 16)))
                              (display ")"))
                            (lambda ()
                              (indent 15)
                              (write #f)
                              (indent 15))
                            text))
             text)