sicp-ex-4.34

  
  
  
 ;; based on 4-33 
  
 (map (lambda (name obj) 
         (define-variable!  name (list 'primitive obj) the-global-environment)) 
     (list 'raw-cons 'raw-car 'raw-cdr) 
     (list cons car cdr)) 
  
 (actual-value 
     '(begin 
  
         (define (cons x y) 
             (raw-cons 'cons (lambda (m) (m x y)))) 
  
         (define (car z) 
             ((raw-cdr z) (lambda (p q) p))) 
  
         (define (cdr z) 
             ((raw-cdr z) (lambda (p q) q))) 
     ) 
     the-global-environment) 
  
 (define (disp-cons obj depth) 
     (letrec ((user-car (lambda (z) 
                 (force-it (lookup-variable-value 'x (procedure-environment (cdr z)))))) 
              (user-cdr (lambda (z) 
                 (force-it (lookup-variable-value 'y (procedure-environment (cdr z))))))) 
         (cond 
             ((>= depth 10) 
                 (display "... )")) 
             ((null? obj) 
                 (display "")) 
             (else 
                 (let ((cdr-value (user-cdr obj))) 
                     (display "(") 
                     (display (user-car obj)) 
                     (if (tagged-list? cdr-value 'cons) 
                         (begin 
                             (display " ") 
                             (disp-cons cdr-value (+ depth 1))) 
                         (begin 
                             (display " . ") 
                             (display cdr-value))) 
                     (display ")")))))) 
  
 (define (user-print object) 
     (if (compound-procedure? object) 
         (display 
             (list 'compound-procedure 
                 (procedure-parameters object) 
                 (procedure-body object) 
                 '<procedure-env>)) 
         (if (tagged-list? object 'cons) 
             (disp-cons object 0) 
             (display object)))) 
  
 (driver-loop) 

Arguably a bit more elegant solution:

  
 (define (setup-environment) 
     (let ((initial-env 
            (extend-environment (primitive-procedure-names) 
                                (primitive-procedure-objects) 
                                the-empty-environment))) 
         (define-variable! 'true true initial-env) 
         (define-variable! 'false false initial-env) 
         (eval 
          '(begin 
               (define (cons cons-first cons-rest) 
                   (lambda (m) (m cons-first cons-rest))) 
               (define (car z) 
                   (z (lambda (p q) p))) 
               (define (cdr z) 
                   (z (lambda (p q) q))) 
               (define (null? c) 
                   (equal? c '()))) 
          initial-env) 
         initial-env)) 
  
  
 (define (lookup-variable-value* var env) 
     (define (env-loop env) 
         (define (scan vars vals) 
             (cond ((null? vars) 
                    (env-loop (enclosing-environment env))) 
                   ((eq? var (car vars)) 
                    (car vals)) 
                   (else (scan (cdr vars) (cdr vals))))) 
         (if (eq? env the-empty-environment) 
             '() 
             (let ((frame (first-frame env))) 
                 (scan (frame-variables frame) 
                       (frame-values frame))))) 
     (env-loop env)) 
  
 (define (lazy-cons? procedure) 
     (let ((env (procedure-environment procedure))) 
         (and (not (null? (lookup-variable-value* 'cons-first env))) 
              (not (null? (lookup-variable-value* 'cons-rest env)))))) 
  
 (define (lazy-cons-print object) 
     (define (lazy-cons-print-internal object n) 
         (if (not (null? object)) 
             (let* ((env (procedure-environment object)) 
                    (first (lookup-variable-value* 'cons-first env)) 
                    (rest (lookup-variable-value* 'cons-rest env))) 
                 (if (> n 10) 
                     (display "...") 
                     (begin 
                         (let ((first-forced (force-it first))) 
                             (if (and (compound-procedure? first-forced) 
                                      (lazy-cons? first-forced)) 
                                 (lazy-cons-print first-forced) 
                                 (display first-forced))) 
                         (display " ") 
                         (lazy-cons-print-internal 
                          (force-it rest) 
                          (+ n 1))))))) 
     (display "(") 
     (lazy-cons-print-internal object 0) 
     (display ")")) 
  
 (define (user-print object) 
     (if (compound-procedure? object) 
         (if (lazy-cons? object) 
             (lazy-cons-print object) 
             (display (list 'compound-procedure 
                            (procedure-parameters object) 
                            (procedure-body object) 
                            '<procedure-env>))) 
         (display object))) 
  
 ;; To test: 
 ;; '(a b (c d)) 
 ;; (define ones (cons 1 ones)) 
 ;; ones