diff --git a/collects/drracket/private/syncheck/contract-traversal.rkt b/collects/drracket/private/syncheck/contract-traversal.rkt
index 6a004b8168..39cf978b64 100644
--- a/collects/drracket/private/syncheck/contract-traversal.rkt
+++ b/collects/drracket/private/syncheck/contract-traversal.rkt
@@ -7,16 +7,20 @@
 (provide annotate-contracts)
 
 (define (annotate-contracts stx low-binders binding-inits)
-  (define start-map (make-hash))
+  (define boundary-start-map (make-hash))
+  (define internal-start-map (make-hash))
   (define arrow-map (make-hash))
   (define domain-map (make-hash))
   (define range-map (make-hash))
   
-  ;; coloring-plans : hash[stx -o-> (listof color)]
-  (define coloring-plans (make-hash))
+  ;; my-coloring-plans : hash[stx -o-> (listof color)]
+  (define my-coloring-plans (make-hash))
+  ;; client-coloring-plans : hash[stx -o-> (listof color)]
+  (define client-coloring-plans (make-hash))
   
   (let loop ([stx stx])
-    (add-to-map stx 'racket/contract:contract-on-boundary start-map)
+    (add-to-map stx 'racket/contract:contract-on-boundary boundary-start-map)
+    (add-to-map stx 'racket/contract:internal-contract internal-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)
@@ -24,32 +28,48 @@
       [(a . b) (loop #'a) (loop #'b)]
       [else (void)]))
   
-  ;; fill in the coloring-plans table
-  (for ([(start-k start-val) (in-hash start-map)])
+  ;; fill in the coloring-plans table for boundary contracts
+  (for ([(start-k start-val) (in-hash boundary-start-map)])
     (for ([start-stx (in-list start-val)])
-      (do-contract-traversal start-stx
-                             coloring-plans
+      (do-contract-traversal start-stx #t
+                             my-coloring-plans client-coloring-plans
+                             low-binders binding-inits
+                             arrow-map domain-map range-map
+                             #t)))
+  
+  ;; fill in the coloring-plans table for internal contracts
+  (for ([(start-k start-val) (in-hash internal-start-map)])
+    (for ([start-stx (in-list start-val)])
+      (do-contract-traversal start-stx #f
+                             my-coloring-plans client-coloring-plans
                              low-binders binding-inits
                              arrow-map domain-map range-map
                              #t)))
   
   ;; enact the coloring plans
-  (for ([(stx colors) (in-hash coloring-plans)])
-    (cond
-      [(and (member my-obligation-style-name colors)
-            (member their-obligation-style-name colors))
-       (color stx both-obligation-style-name 'contract-mode)]
-      [(member my-obligation-style-name colors)
-       (color stx my-obligation-style-name 'contract-mode)]
-      [(member their-obligation-style-name colors)
-       (color stx their-obligation-style-name 'contract-mode)]
-      [(member unk-obligation-style-name colors)
-       (color stx unk-obligation-style-name 'contract-mode)])))
+  (for ((coloring-plans (in-list (list my-coloring-plans client-coloring-plans)))
+        (mode (in-list '(my-obligations-mode client-obligations-mode))))
+    (for ([(stx colors) (in-hash coloring-plans)])
+      (cond
+        [(and (member my-obligation-style-name colors)
+              (member their-obligation-style-name colors))
+         (color stx both-obligation-style-name mode)]
+        [(member my-obligation-style-name colors)
+         (color stx my-obligation-style-name mode)]
+        [(member their-obligation-style-name colors)
+         (color stx their-obligation-style-name mode)]
+        [(member unk-obligation-style-name colors)
+         (color stx unk-obligation-style-name mode)]))))
 
-(define (do-contract-traversal start-stx coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)
+(define (do-contract-traversal start-stx boundary-contract?
+                               my-coloring-plans client-coloring-plans
+                               low-binders binding-inits arrow-map domain-map range-map polarity)
   (let ploop ([stx start-stx]
               [polarity polarity])
     
+    (define (call-give-up)
+      (give-up start-stx boundary-contract? my-coloring-plans client-coloring-plans))
+    
     (let ([main-prop (syntax-property stx 'racket/contract:contract)])
       (cond
         [main-prop
@@ -61,11 +81,15 @@
              [(vector? prop)
               (let ([id (vector-ref prop 0)]
                     [to-color (vector-ref prop 1)])
-                (base-color to-color polarity coloring-plans)
+                (base-color #'id polarity boundary-contract? my-coloring-plans client-coloring-plans)
                 (for ((stx (in-list (hash-ref domain-map id '()))))
-                  (do-contract-traversal stx coloring-plans low-binders binding-inits arrow-map domain-map range-map (not polarity)))
+                  (do-contract-traversal stx boundary-contract?
+                                         my-coloring-plans client-coloring-plans
+                                         low-binders binding-inits arrow-map domain-map range-map (not polarity)))
                 (for ((stx (in-list (hash-ref range-map id '()))))
-                  (do-contract-traversal stx coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)))]))]
+                  (do-contract-traversal stx boundary-contract?
+                                         my-coloring-plans client-coloring-plans
+                                         low-binders binding-inits arrow-map domain-map range-map polarity)))]))]
         
         [else
          ;; we didn't find a contract, but we might find one in a subexpression
@@ -74,33 +98,44 @@
            [(#%expression expr)
             (ploop #'expr polarity)]
            [(module id name-id (#%plain-module-begin mod-level-form ...))
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(begin tl-form ... last-one)
             (ploop #'last-one polarity)]
            [(#%provide pvd ...)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(define-values (id ...) expr)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(define-syntaxes (id ...) expr)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(define-values-for-syntax (id ...) expr)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(#%require rspec ...)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [id
             (identifier? #'id)
             (if (known-predicate? #'id)
-                (base-color #'id polarity coloring-plans)
+                (base-color #'id polarity boundary-contract? my-coloring-plans client-coloring-plans)
                 (let ([binders (module-identifier-mapping-get low-binders #'id (λ () #f))])
                   (if binders
-                      (for ((binder (in-list (module-identifier-mapping-get low-binders #'id))))
-                        (for ((rhs (in-list (module-identifier-mapping-get binding-inits binder))))
-                          (ploop rhs polarity)))
-                      (give-up start-stx coloring-plans))))]
+                      (begin
+                        (base-color #'id polarity boundary-contract? my-coloring-plans client-coloring-plans)
+                        (for ((binder (in-list (module-identifier-mapping-get low-binders #'id))))
+                          (base-color binder polarity boundary-contract? my-coloring-plans client-coloring-plans)
+                          (for ((rhs (in-list (module-identifier-mapping-get binding-inits binder))))
+                            (ploop rhs polarity))))
+                      (call-give-up))))]
+           [(#%plain-lambda (id) expr ...)
+            (identifier? #'id)
+            (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
+           [(#%plain-lambda id expr ...)
+            (identifier? #'id)
+            (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
            [(#%plain-lambda formals expr ...)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(case-lambda [formals expr] ...)
-            (give-up start-stx coloring-plans)]
+            ;; this should really only happen when the arity of the case-lambda includes 1
+            ;; (otherwise we should call give-up)
+            (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
            [(if a b c)
             ;; these calls are questionable. 
             ;; if we ultimately end up giving up in both
@@ -110,8 +145,12 @@
             ;; on the other hand, recurring like this will mean that the two
             ;; branches are considered separately and thus calling give-up
             ;; on one side will not pollute the other side.
-            (do-contract-traversal #'b coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)
-            (do-contract-traversal #'c coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)]
+            (do-contract-traversal #'b boundary-contract?
+                                   my-coloring-plans client-coloring-plans
+                                   low-binders binding-inits arrow-map domain-map range-map polarity)
+            (do-contract-traversal #'c boundary-contract?
+                                   my-coloring-plans client-coloring-plans
+                                   low-binders binding-inits arrow-map domain-map range-map polarity)]
            ;; [(begin expr ...) (void)]
            [(begin0 fst rst ...)
             (ploop #'fst polarity)]
@@ -120,19 +159,19 @@
            [(letrec-values bindings body ... last-one)
             (ploop #'last-one polarity)]
            [(set! a b)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(quote stuff)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(quote-syntax stuff)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(with-continuation-mark a b c)
             (ploop #'c polarity)]
            [(#%plain-app f args ...)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(#%top . id)
-            (give-up start-stx coloring-plans)]
+            (call-give-up)]
            [(#%variable-reference ignored ...)
-            (give-up start-stx coloring-plans)])]))))
+            (call-give-up)])]))))
 
 ;; add-to-map : syntax any hash[any -> (listof stx)]
 ;; looks at stx's property prop and updates map,
@@ -158,31 +197,39 @@
            (let-values ([(base rel) (module-path-index-split src)])
              (member base '('#%kernel racket racket/base scheme scheme/base)))))))
 
-(define (give-up stx coloring-plans) 
+(define (give-up stx boundary-contract? my-coloring-plans client-coloring-plans)
   (let loop ([stx stx])
     (when (syntax-original? stx)
-      (blank-color stx coloring-plans))
+      (blank-color stx boundary-contract? my-coloring-plans client-coloring-plans))
     
     (let oloop ([origin (syntax-property stx 'origin)])
       (cond
         [(pair? origin) (oloop (car origin)) (oloop (cdr origin))]
         [(syntax? origin) 
          (when (syntax-original? origin)
-           (blank-color origin coloring-plans))]))
+           (blank-color origin boundary-contract? my-coloring-plans client-coloring-plans))]))
     
     (syntax-case stx ()
       [(a . b) (loop #'a) (loop #'b)]
       [_ (void)])))
 
+(define (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)
+  (let ([style (if polarity my-obligation-style-name their-obligation-style-name)]
+        [neg-style (if polarity their-obligation-style-name my-obligation-style-name)])
+    (cond
+      [boundary-contract?
+       (make-a-coloring-plan stx style my-coloring-plans)
+       (make-a-coloring-plan stx neg-style client-coloring-plans)]
+      [else
+       (make-a-coloring-plan stx style my-coloring-plans)])))
 
-
-(define (base-color stx polarity coloring-plans)
-  (make-a-coloring-plan stx
-                        (if polarity my-obligation-style-name their-obligation-style-name)
-                        coloring-plans))
-
-(define (blank-color stx coloring-plans)
-  (make-a-coloring-plan stx unk-obligation-style-name coloring-plans))
+(define (blank-color stx boundary-contract? my-coloring-plans client-coloring-plans)
+  (cond
+    [boundary-contract?
+     (make-a-coloring-plan stx unk-obligation-style-name my-coloring-plans)
+     (make-a-coloring-plan stx unk-obligation-style-name client-coloring-plans)]
+    [else
+     (make-a-coloring-plan stx unk-obligation-style-name my-coloring-plans)]))
 
 (define (make-a-coloring-plan stx plan coloring-plans)
   (hash-set! coloring-plans
diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt
index d34b86cadd..00ad7d67ab 100644
--- a/collects/drracket/private/syncheck/gui.rkt
+++ b/collects/drracket/private/syncheck/gui.rkt
@@ -57,10 +57,10 @@ If the namespace does not, they are colored the unbound color.
 (define jump-to-binding (string-constant cs-jump-to-binding))
 (define jump-to-definition (string-constant cs-jump-to-definition))
 
-(define cs-mode-menu-show-contract "Show Contract Obligations")
-(define cs-mode-menu-show-syntax "Show Syntactic Categories")
-
-
+(define cs-check-syntax-mode (string-constant cs-check-syntax-mode))
+(define cs-mode-menu-show-my-obligations (string-constant cs-mode-menu-show-my-obligations))
+(define cs-mode-menu-show-client-obligations (string-constant cs-mode-menu-show-client-obligations))
+(define cs-mode-menu-show-syntax (string-constant cs-mode-menu-show-syntax))
 
 (define tool@ 
   (unit 
@@ -341,6 +341,9 @@ If the namespace does not, they are colored the unbound color.
                 (when f
                   (send f open-status-line 'drracket:check-syntax:mouse-over))))
             
+            (define/public (syncheck:arrows-visible?)
+              (or arrow-vectors cursor-location cursor-text))
+            
             ;; syncheck:clear-arrows : -> void
             (define/public (syncheck:clear-arrows)
               (when (or arrow-vectors cursor-location cursor-text)
@@ -988,23 +991,25 @@ If the namespace does not, they are colored the unbound color.
           (syncheck:clear-highlighting))
         
         (define/public (syncheck:clear-error-message)
-          (set! error-report-visible? #f)
-          (send report-error-text clear-output-ports)
-          (send report-error-text lock #f)
-          (send report-error-text delete/io 0 (send report-error-text last-position))
-          (send report-error-text lock #t)
-          (when (is-current-tab?)
-            (send (get-frame) hide-error-report)
-            (send (get-frame) update-menu-item-label this)))
+          (unless error-report-visible?
+            (set! error-report-visible? #f)
+            (send report-error-text clear-output-ports)
+            (send report-error-text lock #f)
+            (send report-error-text delete/io 0 (send report-error-text last-position))
+            (send report-error-text lock #t)
+            (when (is-current-tab?)
+              (send (get-frame) hide-error-report)
+              (send (get-frame) update-menu-status this))))
         
         (define/public (syncheck:clear-highlighting)
-          (let* ([definitions (get-defs)]
-                 [locked? (send definitions is-locked?)])
-            (send definitions begin-edit-sequence #f)
-            (send definitions lock #f)
-            (send definitions syncheck:clear-arrows)
-            (send definitions lock locked?)
-            (send definitions end-edit-sequence)))
+          (let ([definitions (get-defs)])
+            (when (send definitions syncheck:arrows-visible?)
+              (let ([locked? (send definitions is-locked?)])
+                (send definitions begin-edit-sequence #f)
+                (send definitions lock #f)
+                (send definitions syncheck:clear-arrows)
+                (send definitions lock locked?)
+                (send definitions end-edit-sequence)))))
         
         (define/augment (can-close?)
           (and (send report-error-text can-close?)
@@ -1032,7 +1037,7 @@ If the namespace does not, they are colored the unbound color.
               (show-error-report)
               (hide-error-report))
           (send report-error-canvas set-editor (send new-tab get-error-report-text))
-          (update-menu-item-label new-tab)
+          (update-menu-status new-tab)
           (update-button-visibility/tab new-tab))
         
         (define/private (update-button-visibility/tab tab)
@@ -1049,11 +1054,13 @@ If the namespace does not, they are colored the unbound color.
         
         (define/augment (enable-evaluation)
           (send check-syntax-button enable #t)
-          (send mode-menu-item enable #t)
+          (send mode-menu-item1 enable #t)
+          (send mode-menu-item2 enable #t)
           (inner (void) enable-evaluation))
         
         (define/augment (disable-evaluation)
-          (send mode-menu-item enable #f)
+          (send mode-menu-item1 enable #f)
+          (send mode-menu-item2 enable #f)
           (send check-syntax-button enable #f)
           (inner (void) disable-evaluation))
         
@@ -1115,36 +1122,47 @@ If the namespace does not, they are colored the unbound color.
             (set! rest-panel r-root)
             r-root))
         
-        (define mode-menu-item #f)
+        (define mode-menu-item1 #f)
+        (define mode-menu-item2 #f)
+        (define mode-menu-item3 #f)
         
         (define/override (add-show-menu-items show-menu)
+          (define (start-checking mode)
+            (let* ([tab (get-current-tab)]
+                   [defs (send tab get-defs)])
+              (cond
+                [(send defs get-syncheck-mode)
+                 (send defs set-syncheck-mode mode)
+                 (update-menu-status tab)]
+                [else
+                 (syncheck:button-callback #f mode)])))
+          
           (super add-show-menu-items show-menu)
-          (set! mode-menu-item
-                (new menu-item% 
-                     [parent show-menu]
-                     [label ""]
-                     [callback
-                      (λ (a b)
-                        (let ([defs (send (get-current-tab) get-defs)])
-                          (case (send defs get-syncheck-mode)
-                            [(#f) (syncheck:button-callback #f 'contract-mode)]
-                            [(default-mode)
-                             (send defs set-syncheck-mode 'contract-mode)
-                             (update-menu-item-label (get-current-tab))]
-                            [else 
-                             (send defs set-syncheck-mode 'default-mode)
-                             (update-menu-item-label (get-current-tab))])))])))
+          (let ([p (new menu%
+                        [parent show-menu]
+                        [label cs-check-syntax-mode])])
+            (set! mode-menu-item1
+                  (new checkable-menu-item% 
+                       [parent p]
+                       [label cs-mode-menu-show-syntax]
+                       [callback (λ (a b) (start-checking 'default-mode))]))
+            (set! mode-menu-item2
+                  (new checkable-menu-item% 
+                       [parent p]
+                       [label cs-mode-menu-show-my-obligations]
+                       [callback (λ (a b) (start-checking 'my-obligations-mode))]))
+            (set! mode-menu-item3
+                  (new checkable-menu-item%
+                       [parent p]
+                       [label cs-mode-menu-show-client-obligations]
+                       [callback (λ (a b) (start-checking 'client-obligations-mode))]))))
         
-        (define/public (update-menu-item-label tab)
-          (when mode-menu-item
+        (define/public (update-menu-status tab)
+          (when mode-menu-item1
             (let ([mode (send (send (get-current-tab) get-defs) get-syncheck-mode)])
-              (case mode
-                [(#f) 
-                 (send mode-menu-item set-label cs-mode-menu-show-contract)]
-                [(default-mode)
-                 (send mode-menu-item set-label cs-mode-menu-show-contract)]
-                [(contract-mode)
-                 (send mode-menu-item set-label cs-mode-menu-show-syntax)]))))
+              (send mode-menu-item1 check (eq? mode 'default-mode))
+              (send mode-menu-item2 check (eq? mode 'my-obligations-mode))
+              (send mode-menu-item3 check (eq? mode 'client-obligations-mode)))))
                 
         (inherit open-status-line close-status-line update-status-line ensure-rep-hidden)
         ;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void)
@@ -1276,7 +1294,7 @@ If the namespace does not, they are colored the unbound color.
                                         (parameterize ([currently-processing-definitions-text definitions-text])
                                           (expansion-completed user-namespace user-directory)
                                           (send (send (get-current-tab) get-defs) set-syncheck-mode mode)
-                                          (update-menu-item-label (get-current-tab))
+                                          (update-menu-status (get-current-tab))
                                           (send definitions-text syncheck:sort-bindings-table))))
                                      (cleanup)
                                      (custodian-shutdown-all user-custodian))))]
diff --git a/collects/drracket/private/syncheck/intf.rkt b/collects/drracket/private/syncheck/intf.rkt
index bc39060bfc..c10df9588c 100644
--- a/collects/drracket/private/syncheck/intf.rkt
+++ b/collects/drracket/private/syncheck/intf.rkt
@@ -7,6 +7,7 @@
 (define-local-member-name
   syncheck:init-arrows
   syncheck:clear-arrows
+  syncheck:arrows-visible?
   syncheck:add-menu
   syncheck:add-arrow
   syncheck:add-tail-arrow
@@ -34,12 +35,13 @@
   
   set-syncheck-mode
   get-syncheck-mode
-  update-menu-item-label)
+  update-menu-status)
 
 (define syncheck-text<%>
   (interface ()
     syncheck:init-arrows
     syncheck:clear-arrows
+    syncheck:arrows-visible?
     syncheck:add-menu
     syncheck:add-arrow
     syncheck:add-tail-arrow
@@ -74,6 +76,7 @@
          ;; methods
          syncheck:init-arrows
          syncheck:clear-arrows
+         syncheck:arrows-visible?
          syncheck:add-menu
          syncheck:add-arrow
          syncheck:add-tail-arrow
@@ -101,4 +104,4 @@
          
          set-syncheck-mode
          get-syncheck-mode
-         update-menu-item-label)
\ No newline at end of file
+         update-menu-status)
\ No newline at end of file
diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt
index a100988193..ed339da204 100644
--- a/collects/string-constants/english-string-constants.rkt
+++ b/collects/string-constants/english-string-constants.rkt
@@ -197,6 +197,12 @@ please adhere to these guidelines:
  (cs-set!d-variable "set!’d variable")
  (cs-imported-variable "imported variable")
 
+  ;; mode sub-menu in the "view" menu
+  (cs-check-syntax-mode "Check Syntax Mode")
+  (cs-mode-menu-show-my-obligations "My Contract Obligations")
+  (cs-mode-menu-show-client-obligations "Client Contract Obligations")
+  (cs-mode-menu-show-syntax "Syntactic Categories")
+  
  ;;; info bar at botttom of drscheme frame
  (collect-button-label "GC")
   (read-only "Read only")