diff --git a/collects/plai/mutator.ss b/collects/plai/mutator.ss
index 337c4d2f1a..259629b6d4 100644
--- a/collects/plai/mutator.ss
+++ b/collects/plai/mutator.ss
@@ -453,7 +453,7 @@
   (cond
     [(procedure? proc/loc) proc/loc]
     [(location? proc/loc) (collector:deref proc/loc)]
-    [else (error 'deref "expected <location?> or <procedure?; received ~a" proc/loc)]))
+    [else (error 'deref "expected <location?> or <procedure?>; received ~a" proc/loc)]))
 
 (define (gc->scheme loc)
   (define-struct an-unset ())
diff --git a/collects/plai/private/random-mutator.ss b/collects/plai/private/random-mutator.ss
index 3ec511f4d4..f0d9f7aba5 100644
--- a/collects/plai/private/random-mutator.ss
+++ b/collects/plai/private/random-mutator.ss
@@ -5,12 +5,18 @@
          "gc-core.ss")
 
 (provide save-random-mutator 
-         find-heap-values)
+         find-heap-values
+         (struct-out terminal)
+         (struct-out proc)
+         (struct-out pair)
+         (struct-out obj-graph)
+         obj-graph->code)
 
 ;; graph : hash-table[number -o> obj]
 ;; path : sexp
 ;; result : flat-value
-(define-struct obj-graph (graph path result id) #:transparent)
+;; root : nat (the id of the reference to keep live)
+(define-struct obj-graph (graph path result root) #:transparent)
 
 ;; an obj is either:
 ;;  - (make-terminal <constant>)
@@ -21,6 +27,12 @@
 (define-struct proc (ids) #:transparent)
 (define-struct pair (hd tl) #:transparent)
 
+;; select : (or/c 'first 'rest nat)
+;;    numbers indicate the selector is to call a proc with that number
+;;    'first and 'rest indicate the selector is either first or rest.
+;; id : num
+(define-struct connection (select id) #:transparent)
+
 (define (random-obj-graph size heap-values)
   (let ([num-cells (+ 1 (random size))]
         [hash (make-hash)])
@@ -36,13 +48,9 @@
                [codes '()])
       (let ([done
              (λ ()
-               (values 
-                (let loop ([codes (reverse codes)])
-                  (cond
-                    [(null? codes) (obj-num->id last-id)]
-                    [else ((car codes) (loop (cdr codes)))]))
-                (terminal-const first-terminal)
-                (obj-num->id last-id)))])
+               (values codes
+                       (terminal-const first-terminal)
+                       last-id))])
         (cond
           [(zero? i) (done)]
           [else
@@ -50,14 +58,42 @@
              (cond
                [next (loop (- i 1)
                            (connection-id next)
-                           (cons (connection-code next) codes))]
+                           (cons (connection-select next) codes))]
                [else (done)]))])))))
 
-;; code : sexp -> sexp
-;; id : number 
-(define-struct connection (code id))
+;; find-connection-to : hash id -> connection
+;; returns a random choice of one of the nodes with a connection to the node 'id'
+(define (find-connections-to hash id) 
+  (let ([candidate-code '()]
+        [candidate-ids '()])
+    (hash-for-each
+     hash
+     (λ (k v)
+       (cond
+         [(pair? v) 
+          (when (equal? id (pair-hd v))
+            (set! candidate-code (cons 'first candidate-code))
+            (set! candidate-ids (cons k candidate-ids)))
+          (when (equal? id (pair-tl v))
+            (set! candidate-code (cons 'rest candidate-code))
+            (set! candidate-ids (cons k candidate-ids)))]
+         [(terminal? v)
+          (void)]
+         [(proc? v)
+          (for ([proc-id (in-list (proc-ids v))]
+                [case-num (in-naturals)])
+            (when (equal? proc-id id)
+              (set! candidate-code (cons case-num candidate-code))
+              (set! candidate-ids (cons k candidate-ids))))])))
+    (cond
+      [(null? candidate-code)
+       #f]
+      [else
+       (let ([choice (random (length candidate-code))])
+         (make-connection (list-ref candidate-code choice)
+                          (list-ref candidate-ids choice)))])))
 
-;; find-connection-to : hash id -> connection or #f
+#;
 (define (find-connections-to hash id) 
   (let ([candidate-code '()]
         [candidate-ids '()])
@@ -101,7 +137,8 @@
       (values (list-ref candidate-terminals choice)
               (list-ref candidate-ids choice)))))
 
-(define (obj-graph->code obj-graph)
+;; obj-graph->code : obj-graph? nat -> (listof sexp)
+(define (obj-graph->code obj-graph iterations heap-size)
   (let ([graph (obj-graph-graph obj-graph)]
         [init-code '()])
     (list 
@@ -113,10 +150,33 @@
                                  (set! init-code (append cell-init-code init-code)) 
                                  `[,(obj-num->id i) ,binding-code]))))
           ,@(reverse init-code)
-          ,(obj-graph-id obj-graph)))
-     `(define (traverse-one ,(obj-graph-id obj-graph))
+          ,(obj-num->id (obj-graph-root obj-graph))))
+     `(define (traverse-one ,(obj-num->id (obj-graph-root obj-graph)))
         ,(result->comparison (obj-graph-result obj-graph)
-                             (obj-graph-path obj-graph))))))
+                             (let loop ([path (reverse (obj-graph-path obj-graph))])
+                               (cond
+                                 [(null? path) (obj-num->id (obj-graph-root obj-graph))]
+                                 [else 
+                                  (case (car path)
+                                    [(first) `(first ,(loop (cdr path)))]
+                                    [(rest) `(rest ,(loop (cdr path)))]
+                                    [else `(,(loop (cdr path)) ,(car path))])]))))
+     
+     `(define (trigger-gc n)
+        (if (zero? n)
+            0
+            (begin 
+              (cons n n)
+              (trigger-gc (- n 1)))))
+     `(define (loop i)
+        (if (zero? i)
+            'passed
+            (let ([obj (build-one)])
+              (trigger-gc ,heap-size)
+              (if (traverse-one obj)
+                  (loop (- i 1))
+                  'failed))))
+     `(loop ,iterations))))
 
 (define (result->comparison expected-result exp)
   (cond
@@ -128,14 +188,12 @@
         (if (boolean? res)
             res
             #f))]
-    [(eq? expected-result #f) `(not ,exp)]
+    [(eq? expected-result #f) `(if ,exp #f #t)]
     [(null? expected-result) `(empty? ,exp)]
     [else (error 'result->comparison "unknown value ~s\n" expected-result)]))
 
 (define (obj-num->id x) (string->symbol (format "x~a" x)))
 
-(define proc-cases 5)
-
 ;; random-obj : number obj -> (values sexp[constructor] (list sexp[init-code]))
 (define (obj->code cell-number obj)
   (cond
@@ -209,24 +267,8 @@
             (set-first! set-mcar!)
             (set-rest! set-mcdr!)))])
       (for-each (λ (x) (pretty-print x port))
-                (obj-graph->code (random-obj-graph program-size heap-values)))
-      (pretty-print `(define (trigger-gc n)
-                       (if (zero? n)
-                           0
-                           (begin 
-                             (cons n n)
-                             (trigger-gc (- n 1)))))
-                    port)
-      (pretty-print `(define (loop i)
-                       (if (zero? i)
-                           'passed
-                           (let ([obj (build-one)])
-                             (trigger-gc ,heap-size)
-                             (if (traverse-one obj)
-                                 (loop (- i 1))
-                                 'failed))))
-                    port)
-      (pretty-print `(loop ,iterations) port))
+                (obj-graph->code (random-obj-graph program-size heap-values) 
+                                 iterations)))
     #:exists 'truncate))
 
 (define (find-heap-values in)
diff --git a/collects/tests/plai/no-compact-cheat.ss b/collects/tests/plai/no-compact-cheat.ss
index 8bcf2aeeae..ab2c20ff96 100644
--- a/collects/tests/plai/no-compact-cheat.ss
+++ b/collects/tests/plai/no-compact-cheat.ss
@@ -122,7 +122,11 @@ A collector for use in testing the random mutator generator.
 
 
 (define (gc:alloc-flat fv) 
-  (let ([ptr (alloc 2 (λ () (get-root-set)))])
+  (let ([ptr (alloc 2 (λ () 
+                        (if (procedure? fv)
+                            (append (procedure-roots fv)
+                                    (get-root-set))
+                            (get-root-set))))])
     (heap-set! ptr 'flat)
     (heap-set! (+ ptr 1) fv)
     ptr))
diff --git a/collects/tests/plai/test-random-mutator.ss b/collects/tests/plai/test-random-mutator.ss
index cceb90f224..2e1fa0e0ea 100644
--- a/collects/tests/plai/test-random-mutator.ss
+++ b/collects/tests/plai/test-random-mutator.ss
@@ -1,6 +1,80 @@
-#lang scheme/base
+#lang scheme
 (require schemeunit
-         plai/random-mutator)
+         plai/random-mutator
+         scheme/runtime-path
+         ;; test find-heap-values and save-random-mutator via the contract'd
+         ;; interface, just in case they break their contracts
+         (except-in plai/private/random-mutator find-heap-values save-random-mutator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  random mutator generation tests
+;;
+
+(define-runtime-path here ".")
+
+;; test-code : exp -> boolean
+;; returns true if evaluating the example code (as a mutator)
+;; returns one result at the top-level, namely the symbol 'passed.
+(define (test-code exps)
+  (let ([tmpfile (make-temporary-file "plai-random-mutator-test-~a")])
+    (call-with-output-file tmpfile
+      (λ (port)
+        (fprintf port "#lang plai/mutator\n")
+        (fprintf port "~s\n" `(allocator-setup ,(path->string
+                                                 (find-relative-path 
+                                                  (simple-form-path tmpfile)
+                                                  (build-path (simple-form-path here)
+                                                              "no-compact-cheat.ss")))
+                                               100))
+        (for-each (λ (exp) (pretty-print exp port)) exps))
+      #:exists 'truncate)
+
+    (let ([sp (open-output-string)])
+      (parameterize ([current-output-port sp])
+        (dynamic-require tmpfile #f))
+      (delete-file tmpfile)
+      (and (regexp-match #rx"Value at location [0-9]+:\npassed\n"
+                         (get-output-string sp))
+           #t))))
+
+
+(define (make-simple-obj-graph/code heap-value)
+  (obj-graph->code (make-obj-graph
+                    (let ([ht (make-hash)])
+                      (hash-set! ht 0 (make-terminal heap-value))
+                      ht)
+                    '()
+                    heap-value
+                    0)
+                   1
+                   100))
+
+(check-true (test-code (list ''passed)))
+(check-true (test-code (make-simple-obj-graph/code 'z)))
+(check-true (test-code (make-simple-obj-graph/code 111)))
+(check-true (test-code (make-simple-obj-graph/code '())))
+(check-true (test-code (make-simple-obj-graph/code #t)))
+(check-true (test-code (make-simple-obj-graph/code #f)))
+(check-true (test-code
+             (obj-graph->code (make-obj-graph
+                               (let ([ht (make-hash)])
+                                 (hash-set! ht 2 (make-pair 2 1))
+                                 (hash-set! ht 1 (make-pair 3 4))
+                                 (hash-set! ht 0 (make-terminal 'z))
+                                 (hash-set! ht 4 (make-pair 0 0))
+                                 (hash-set! ht 3 (make-proc (list 0 1 2 0 1)))
+                                 ht)
+                               '(first 2 rest first 4 first 3)
+                               'z
+                               1)
+                              1
+                              100)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  find-heap-values tests
+;;
 
 (check-equal?
  (find-heap-values