diff --git a/collects/drracket/private/syncheck/annotate.rkt b/collects/drracket/private/syncheck/annotate.rkt
new file mode 100644
index 0000000000..6668e960a2
--- /dev/null
+++ b/collects/drracket/private/syncheck/annotate.rkt
@@ -0,0 +1,77 @@
+#lang racket/base
+(require racket/class
+         racket/gui/base
+         framework
+         "intf.rkt")
+(provide color color-range
+         find-source-editor
+         find-source-editor/defs
+         get-defs-text)
+
+;; color : syntax[original] str -> void
+;; colors the syntax with style-name's style
+(define (color stx style-name mode)
+  (let ([source (find-source-editor stx)])
+    (when (and (is-a? source text%)
+               (syntax-position stx)
+               (syntax-span stx))
+      (let ([pos (- (syntax-position stx) 1)]
+            [span (syntax-span stx)])
+        (color-range source pos (+ pos span) style-name mode)))))
+
+;; color-range : text start finish style-name 
+;; colors a range in the text based on `style-name'
+(define (color-range source start finish style-name mode)
+  (let ([style (send (send source get-style-list)
+                     find-named-style
+                     style-name)])
+    (apply-style/remember source start finish style mode)))
+
+;; find-source-editor : stx -> editor or false
+(define (find-source-editor stx)
+  (let ([defs-text (get-defs-text)])
+    (and defs-text 
+         (find-source-editor/defs stx defs-text))))
+
+;; find-source-editor : stx text -> editor or false
+(define (find-source-editor/defs stx defs-text)
+  (cond
+    [(not (syntax-source stx)) #f]
+    [(and (symbol? (syntax-source stx))
+          (text:lookup-port-name (syntax-source stx)))
+     => values]
+    [else
+     (let txt-loop ([text defs-text])
+       (cond
+         [(and (is-a? text text:basic<%>)
+               (send text port-name-matches? (syntax-source stx)))
+          text]
+         [else
+          (let snip-loop ([snip (send text find-first-snip)])
+            (cond
+              [(not snip)
+               #f]
+              [(and (is-a? snip editor-snip%)
+                    (send snip get-editor))
+               (or (txt-loop (send snip get-editor))
+                   (snip-loop (send snip next)))]
+              [else 
+               (snip-loop (send snip next))]))]))]))
+;; get-defs-text : -> text or false
+(define (get-defs-text)
+  (currently-processing-definitions-text))
+
+;; apply-style/remember : (is-a?/c editor<%>) number number style% symbol -> void
+(define (apply-style/remember ed start finish style mode)
+  (let ([outermost (find-outermost-editor ed)])
+    (and (is-a? outermost syncheck-text<%>)
+         (send outermost syncheck:apply-style/remember ed start finish style mode))))
+
+(define (find-outermost-editor ed)
+  (let loop ([ed ed])
+    (let ([admin (send ed get-admin)])
+      (if (is-a? admin editor-snip-editor-admin<%>)
+          (let* ([enclosing-snip (send admin get-snip)]
+                 [enclosing-snip-admin (send enclosing-snip get-admin)])
+            (loop (send enclosing-snip-admin get-editor)))
+          ed))))
diff --git a/collects/drracket/private/syncheck/contract-traversal.rkt b/collects/drracket/private/syncheck/contract-traversal.rkt
new file mode 100644
index 0000000000..d435fb6364
--- /dev/null
+++ b/collects/drracket/private/syncheck/contract-traversal.rkt
@@ -0,0 +1,146 @@
+#lang racket/base
+(require "intf.rkt" 
+         "annotate.rkt"
+         "colors.rkt"
+         syntax/kerncase)
+(provide annotate-contracts)
+
+(define (annotate-contracts stx)
+  (define start-map (make-hash))
+  (define arrow-map (make-hash))
+  (define domain-map (make-hash))
+  (define range-map (make-hash))
+  
+  (let loop ([stx stx])
+    (add-to-map stx 'racket/contract:contract-on-boundary start-map)
+    (add-to-map stx 'racket/contract:domain-of domain-map)
+    (add-to-map stx 'racket/contract:rng-of range-map)
+    (add-to-map stx 'racket/contract:function-contract arrow-map)
+    (syntax-case stx ()
+      [(a . b) (loop #'a) (loop #'b)]
+      [else (void)]))
+  
+  (for ([(start-k start-val) (in-hash start-map)])
+    (for ([start-stx (in-list start-val)])
+      (do-contract-traversal start-stx arrow-map domain-map range-map #t))))
+
+(define (do-contract-traversal start-stx arrow-map domain-map range-map polarity)
+  (let loop ([stx start-stx])
+    (base-color stx polarity)
+    (kernel-syntax-case stx #f
+      [(#%expression expr)
+       (loop #'expr)]
+      [(module id name-id (#%plain-module-begin mod-level-form ...))
+       (for-each loop (syntax->list #'(mod-level-form ...)))]
+      [(begin tl-form ... last-one)
+       (loop #'last-one)]
+      [(#%provide pvd ...)
+       (void)]
+      [(define-values (id ...) expr)
+       (void)]
+      [(define-syntaxes (id ...) expr)
+       (void)]
+      [(define-values-for-syntax (id ...) expr)
+       (void)]
+      [(#%require rspec ...)
+       (void)]
+      [id
+       (identifier? #'id)
+       (void)]
+      [(#%plain-lambda formals expr ...)
+       (void)]
+      [(case-lambda [formals expr] ...)
+       (void)]
+      [(if a b c)
+       (loop #'b)
+       (loop #'c)]
+      ;; [(begin expr ...) (void)]
+      [(begin0 fst rst ...)
+       (loop #'fst)]
+      [(let-values bindings body ... last-one)
+       (loop #'last-one)]
+      [(letrec-values bindings body ... last-one)
+       (loop #'last-one)]
+      [(set! a b)
+       (void)]
+      [(quote stuff)
+       (void)]
+      [(quote-syntax stuff)
+       (void)]
+      [(with-continuation-mark a b c)
+       (loop #'c)]
+      [(#%plain-app f args ...)
+       (void)]
+      [(#%top . id)
+       (void)]
+      [(#%variable-reference id)
+       (void)]
+      [(#%variable-reference)
+       (void)])))
+       
+       
+       
+;; add-to-map : syntax any hash[any -> (listof stx)]
+;; looks at stx's property prop and updates map,
+;; using the value of the property as the key
+(define (add-to-map stx prop map)
+  (let loop ([val (syntax-property stx prop)])
+    (cond
+      [(symbol? val)
+       (hash-set! map val (cons stx (hash-ref map val '())))]
+      [(pair? val)
+       (loop (car val))
+       (loop (cdr val))])))
+
+#|
+    (define (annotate-contracts stx)
+      (let loop ([stx stx])
+        (let sloop ([prop (syntax-property stx 'provide/contract-original-contract)])
+          (cond
+            [(vector? prop)
+             (color-obligations (vector-ref prop 1))]
+            [(pair? prop) (sloop (car prop)) 
+                          (sloop (cdr prop))]))
+        (syntax-case stx ()
+          [(a . b) (loop #'a) (loop #'b)]
+          [else (void)])))
+    
+    (define (color-obligations stx)
+      (let loop ([stx stx]
+                 [polarity #t])
+      (syntax-case stx (->)
+        [(-> a ... rng)
+         (begin
+           (base-color (car (syntax-e stx)) polarity)
+           (for-each (λ (x) (loop x (not polarity))) (syntax->list #'(a ...)))
+           (syntax-case #'rng (values any)
+             [(values b ...)
+              (for-each (λ (x) (loop x polarity)) (syntax->list #'(b ...)))]
+             [any
+              (void)]
+             [rng
+              (loop #'rng polarity)]))]
+        [id
+         (and (identifier? #'id)
+              (known-predicate? #'id))
+         (base-color stx polarity)]
+        [else
+         (color stx unk-obligation-style-name 'contract-mode)])))
+|#
+;; returns #t if the result is known to be a predicate that shoudl correspond to a
+;; complete obligation for the contract. If it is some unknown variable, this variable
+;; may refer to some other contract with nested obligations, so we have to return #f here.
+;; approximate this by just asking 'did this identifier come from the core?' (which is known
+;; to not bind any contracts (I hope))
+(define (known-predicate? id)
+  (let ([ib (identifier-binding id)])
+    (and (list? ib)
+         (let ([src (list-ref ib 0)])
+           (let-values ([(base rel) (module-path-index-split src)])
+             (member base '('#%kernel racket racket/base scheme scheme/base)))))))
+
+(define (base-color stx polarity)
+  (printf "base-color ~s\n" stx)
+  (color stx 
+         (if polarity my-obligation-style-name their-obligation-style-name) 
+         'contract-mode))
diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt
index 9b9f2ced4b..d34b86cadd 100644
--- a/collects/drracket/private/syncheck/gui.rkt
+++ b/collects/drracket/private/syncheck/gui.rkt
@@ -939,7 +939,7 @@ If the namespace does not, they are colored the unbound color.
             
             (define/private (apply-syncheck-mode)
               (let ([edit-sequences '()])
-                (for ((l (in-list (reverse (hash-ref style-mapping syncheck-mode)))))
+                (for ((l (in-list (reverse (hash-ref style-mapping syncheck-mode '())))))
                   (let-values ([(txt start finish style) (apply values l)])
                     (unless (memq txt edit-sequences)
                       (send txt begin-edit-sequence #f)
diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt
index 9ae20ec8c4..d62a5f0019 100644
--- a/collects/drracket/private/syncheck/traversals.rkt
+++ b/collects/drracket/private/syncheck/traversals.rkt
@@ -2,6 +2,8 @@
 
 (require "colors.rkt"
          "intf.rkt"
+         "annotate.rkt"
+         "contract-traversal.rkt"
          string-constants
          racket/unit
          racket/contract
@@ -619,80 +621,6 @@
         (color-unused requires unused-requires)
         (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets)))))
     
-    (define (annotate-contracts stx)
-      (define start-map (make-hash))
-      (define arrow-map (make-hash))
-      (define domain-map (make-hash))
-      (define range-map (make-hash))
-      (define (add-to-map stx prop map)
-        (let loop ([val (syntax-property stx prop)])
-          (cond
-            [(symbol? val)
-             (hash-set! map val (cons stx (hash-ref map val '())))]
-            [(pair? val)
-             (loop (car val))
-             (loop (cdr val))])))
-      
-      (let loop ([stx stx])
-        (add-to-map stx 'racket/contract:contract-on-boundary start-map)
-        (add-to-map stx 'racket/contract:domain-of domain-map)
-        (add-to-map stx 'racket/contract:rng-of range-map)
-        (add-to-map stx 'racket/contract:function-contract arrow-map)
-        (syntax-case stx ()
-          [(a . b) (loop #'a) (loop #'b)]
-          [else (void)])))
-    
-#|
-    (define (annotate-contracts stx)
-      (let loop ([stx stx])
-        (let sloop ([prop (syntax-property stx 'provide/contract-original-contract)])
-          (cond
-            [(vector? prop)
-             (color-obligations (vector-ref prop 1))]
-            [(pair? prop) (sloop (car prop)) 
-                          (sloop (cdr prop))]))
-        (syntax-case stx ()
-          [(a . b) (loop #'a) (loop #'b)]
-          [else (void)])))
-    
-    (define (color-obligations stx)
-      (let loop ([stx stx]
-                 [polarity #t])
-      (syntax-case stx (->)
-        [(-> a ... rng)
-         (begin
-           (base-color (car (syntax-e stx)) polarity)
-           (for-each (λ (x) (loop x (not polarity))) (syntax->list #'(a ...)))
-           (syntax-case #'rng (values any)
-             [(values b ...)
-              (for-each (λ (x) (loop x polarity)) (syntax->list #'(b ...)))]
-             [any
-              (void)]
-             [rng
-              (loop #'rng polarity)]))]
-        [id
-         (and (identifier? #'id)
-              (known-predicate? #'id))
-         (base-color stx polarity)]
-        [else
-         (color stx unk-obligation-style-name 'contract-mode)])))
-|#
-    ;; returns #t if the result is known to be a predicate that shoudl correspond to a
-    ;; complete obligation for the contract. If it is some unknown variable, this variable
-    ;; may refer to some other contract with nested obligations, so we have to return #f here.
-    ;; approximate this by just asking 'did this identifier come from the core?' (which is known
-    ;; to not bind any contracts (I hope))
-    (define (known-predicate? id)
-      (let ([ib (identifier-binding id)])
-        (and (list? ib)
-             (let ([src (list-ref ib 0)])
-               (let-values ([(base rel) (module-path-index-split src)])
-                 (member base '('#%kernel racket racket/base scheme scheme/base)))))))
-    
-    (define (base-color stx polarity)
-      (color stx 
-             (if polarity my-obligation-style-name their-obligation-style-name) 
-             'contract-mode))
         
     ;; record-renamable-var : rename-ht syntax -> void
     (define (record-renamable-var rename-ht stx)
@@ -1176,26 +1104,7 @@
                    pos
                    span)
           (send src set-position (- pos 1) (+ pos span -1)))))
-    
-    ;; color : syntax[original] str -> void
-    ;; colors the syntax with style-name's style
-    (define (color stx style-name mode)
-      (let ([source (find-source-editor stx)])
-        (when (and (is-a? source text%)
-                   (syntax-position stx)
-                   (syntax-span stx))
-          (let ([pos (- (syntax-position stx) 1)]
-                [span (syntax-span stx)])
-            (color-range source pos (+ pos span) style-name mode)))))
-    
-    ;; color-range : text start finish style-name 
-    ;; colors a range in the text based on `style-name'
-    (define (color-range source start finish style-name mode)
-      (let ([style (send (send source get-style-list)
-                         find-named-style
-                         style-name)])
-        (apply-style/remember source start finish style mode)))
-    
+
     ;; hash-table[syntax -o> (listof syntax)] -> void
     (define (add-tail-ht-links tail-ht)
       (begin
@@ -1263,54 +1172,7 @@
                    [to-pos (syntax-position to-stx)])
                (and from-pos to-pos)))))
     
-    ;; apply-style/remember : (is-a?/c editor<%>) number number style% symbol -> void
-    (define (apply-style/remember ed start finish style mode)
-      (let ([outermost (find-outermost-editor ed)])
-        (and (is-a? outermost syncheck-text<%>)
-             (send outermost syncheck:apply-style/remember ed start finish style mode))))
-    
-    (define (find-outermost-editor ed)
-      (let loop ([ed ed])
-        (let ([admin (send ed get-admin)])
-          (if (is-a? admin editor-snip-editor-admin<%>)
-              (let* ([enclosing-snip (send admin get-snip)]
-                     [enclosing-snip-admin (send enclosing-snip get-admin)])
-                (loop (send enclosing-snip-admin get-editor)))
-              ed))))
 
-    ;; find-source-editor : stx -> editor or false
-    (define (find-source-editor stx)
-      (let ([defs-text (get-defs-text)])
-        (and defs-text 
-             (find-source-editor/defs stx defs-text))))
-    
-    ;; find-source-editor : stx text -> editor or false
-    (define (find-source-editor/defs stx defs-text)
-      (cond
-        [(not (syntax-source stx)) #f]
-        [(and (symbol? (syntax-source stx))
-              (text:lookup-port-name (syntax-source stx)))
-         => values]
-        [else
-         (let txt-loop ([text defs-text])
-           (cond
-             [(and (is-a? text fw:text:basic<%>)
-                   (send text port-name-matches? (syntax-source stx)))
-              text]
-             [else
-              (let snip-loop ([snip (send text find-first-snip)])
-                (cond
-                  [(not snip)
-                   #f]
-                  [(and (is-a? snip editor-snip%)
-                        (send snip get-editor))
-                   (or (txt-loop (send snip get-editor))
-                       (snip-loop (send snip next)))]
-                  [else 
-                   (snip-loop (send snip next))]))]))]))
-    ;; get-defs-text : -> text or false
-    (define (get-defs-text)
-      (currently-processing-definitions-text))
  
     
 ;